perm filename PARSE.SAI[HAL,HE]6 blob
sn#253986 filedate 1976-12-16 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00062 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 UPDATES TO PARSE BY MSM
C00008 00003 the AL to S-expression translator AND MSM SWITCHES
C00012 00004 ! reserved word classes
C00016 00005
C00018 00006 ! miscellaneous reserved words
C00020 00007 ! dec_name, declaration names for input and output
C00022 00008 ! operators
C00027 00009 ! reserved_words
C00029 00010 ! init_reserved
C00031 00011 ! predefined constants
C00033 00012 ! compiler switches and control tables
C00036 00013 ! hash, declaration of debugging variables, start of hidden_parse
C00039 00014 ! ---- DECLARATIONS ----
C00042 00015 ! record declarations
C00048 00016 ! other declarations
C00050 00017 ! error, error_recovery, error_reject, print, file_indent
C00060 00018 ! read, push_macro_delimiters
C00064 00019 ! macro handling routine
C00072 00020 ! expand_macro
C00076 00021 ! get_token
C00080 00022 ! look for reserved word
C00084 00023 ! check, inverse, multiply and divide dimensions
C00088 00024 ! check_entry,insert_entry into tables
C00092 00025 ! reduce, vmake_R
C00094 00026 ! tmake_r, fmake_r
C00097 00027 ! vvtrans_R, sneg_R
C00100 00028 ! rinv_R, sabs_R
C00102 00029 ! plus_R,minus_R
C00105 00030 ! times_R
C00109 00031 ! rot_R, wrt_R
C00112 00032 ! →_R
C00114 00033 ! reduce execution starts here
C00118 00034 ! printexpr
C00119 00035 ! p_exp2
C00121 00036 ! parse_special
C00127 00037 ! p_exp2 execution begins here, p_exp
C00134 00038 ! P_condition
C00137 00039 ! P_clauses, T_gen
C00147 00040 ! P_statement, begin_P
C00150 00041 ! end_P, open_paren_P
C00151 00042 ! declare_P
C00154 00043 ! global_P
C00157 00044 ! if_P, plan_P, while_P
C00159 00045 ! for_P
C00162 00046 ! move_P
C00164 00047 ! affix_p,unfix_p
C00169 00048 ! signal_p, wait_p
C00171 00049 ! when_P
C00174 00050 ! dump_P
C00176 00051 ! assert_P
C00180 00052 ! on_P, reference_P, parseshit_P, open_P
C00183 00053 ! center_P, stop_P, define_P
C00185 00054 ! require_P
C00192 00055 ! dimension_P
C00198 00056 ! abort_P
C00201 00057 ! P_statement execution starts here
C00207 00058 ! process_switches, got_input, got_output, open_logging_file
C00211 00059 ! execution starts here, initialization
C00214 00060 ! set up input and output
C00217 00061 ! set up predefined dimensions, constants and variables
C00219 00062 ! PARSE PROGRAM
C00222 ENDMK
C⊗;
COMMENT UPDATES TO PARSE BY MSM
12-15-76 BAIL CAN BE CALLED IN FROM REQUIRE SWITCHES INSTRUCTIONS
DEFAULT AND ONLY ACCEPTABLE DIMENSIONS OF FRAME IS DISTANCE
TRANS SHOULD BE DIMENSIONLESS
12-14-76 NEW SETUP FOR RESERVED WORD DEFINITIONS, ETC.
ERROR RECOVERY 55, WHEN FILE ASKED FOR DOES NOT EXIST
COMBINATION OF PLUS_R,MINUS_R
COMBINATION OF TMAKE_R, FMAKE_R
12-10-76 WHEN ERROR OF MACRO WITH PARAMETERS ACTUAL PARAMETERS SUBSTITUTED
ACCEPTS ONLY DISTANCE VECTOR ETC NO LONGER VECTOR DISTANCE
REQUIRE BAIL ADDED
12- 7-76 MACRO EXPANSION OF TEXT OK
12- 6-76 REQUIRE COMMENT_DELIMITERS
11-16-76 NEW CHECK_ENTRY AND INSERT_ENTRY PROCEDURES
11-15-76 INSERTION OF STRICT_DIMEN_CHECK SWITCH
ALL PREDEFINED CONSTANTS DECLARED DIMENSIONLESS
11-14-76 DIMENSIONLESS DECLARATION COERCED TO TYPE OF EXPRESSION
XHAT,YHAT,ZHAT MADE DIMENSIONLESS
11-6-76 NEW WAY OF COMPUTING DIMENSIONS
11-2-76 CHANGE LABEL TO STMLAB ON PG 6
11-2-76 CHANGES TO DECLARE_P TO allow default of distance to frames
11-2-76 LN49 PG 24 ADDED TO GIVE DIMENSION OF FRAME AS DISTANCE
11-2-76 ADDED ELSE DIM←0 AFTER SECOND IF STATEMENT TO CURE BUG ON PG 41 DECLARE_P
11-1-76 WOBBLE COMMAND IMPLEMENTED
10-29-76 LOGGING FEATURE IMPLEMENTED
10-27-76 TVSUB AND VSUB IMPLEMENTED
10-18-76 CHANGE STOP BLUE OR YELLOW TO STOP BARM OR YARM;
comment the AL to S-expression translator AND MSM SWITCHES;
Begin "PARSE"
REQUIRE 1024 STRING_PDL; REQUIRE 1024 STRING_SPACE; REQUIRE 1024 SYSTEM_PDL;
require "[][]" delimiters;
define
α =[begin],
β =[end],
! =[comment],
tab ='11,
lf ='12,
ff ='14,
cr ='15,
space ='40,
dquote ='42,
rubout ='177,
crlf =[('15&'12)],
ampersand ='46,
hasher =256,
preload_array(name, defs, type, first, len)=[
preload_with defs null; type array name[first:first+len] ];
! N.B. -- preload_array always creates an array 1 longer than requested;
! if /nB is set in the command line then assume he wants a debugging parser;
require "<><>" delimiters;
ifc ¬declaration(debug_compile) thenc
define
decipher_debug(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), lf, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), space, null, "IA"))+1 for 1];
"a">;
ifc decipher_debug()="0"
thenc define debug_compile=false;
elsec define debug_compile=true;
endc
endc
require unstack_delimiters;
require ifc ¬debug_compile
thenc " NON-" elsec " " endc & "DEBUGGING VERSION " message;
ifc debug_compile thenc EXTERNAL PROCEDURE BAIL;
REQUIRE "LA" ERROR_MODES; ! to compile and go home when system busy;
endc
define
indices(name, postfix)=[
redefine xxcount=0;
redefine xx(xxarg)=[
redefine xxtemp=[define xxarg] & [postfix=xxcount];
xxtemp;
redefine xxcount=xxcount+1;];
name];
! ID postfix conventions
_VALUE AL data types
_RES reserved word types
_beg reserved word group begin
_end reserved word group end
_R REDUCE action routines
_P PARSE action routines
_TOKEN scanner token types
_CM condition monitors
_X indices of various sorts
_METRIC dimensional analysis non-sense
_DIMEN how to combine various matrix operands
_TYPE to decide which table to insert into
;
define id_type_table=0,
macro_type_table = 1,
macro_in_macro_type_table = 2,
dimension_type_table = 3 ;
! **********; require "SNAILR[HAL,HE]" source_file; ! **********;
! reserved word classes;
redefine xx(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine xx_temp="define " & "str" & "_RES=reserved_X_count";
xx_temp;];
redefine yy(str,str2)=[];
redefine zz(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine zz_temp="define " & "str" & "_RES=reserved_X_count";
zz_temp;];
define statement_definitions=[
xx(BEGIN)
yy(COBEGIN)
xx(END)
yy(COEND)
yy([;])
zz(OPEN_PAREN)
yy([(])
zz(DECLARE)
yy(SCALAR, scalar_value)
yy(VECTOR, vector_value)
yy(ROT, rot_value)
yy(FRAME, frame_value)
yy(PLANE, plane_value)
yy(TRANS, trans_value)
yy(EVENT, event_value)
yy(ATOM, atom_value)
yy(WORLD, world_value)
yy(CM_LABEL, cm_label_value)
yy(CLC_LABEL, clc_label_value)
yy(CH_LABEL, ch_label_value)
yy(LABEL, label_value)
xx(GLOBAL)
xx(IF)
xx(PLAN)
xx(WHILE)
xx(FOR)
xx(MOVE)
xx(AFFIX)
xx(UNFIX)
xx(SIGNAL)
xx(WAIT)
xx(WHEN)
xx(DUMP)
xx(ASSERT)
yy(DENY)
xx(ON)
xx(REFERENCE)
xx(PARSESHIT)
xx(OPEN)
yy(CLOSE)
xx(CENTER)
xx(STOP)
xx(DEFINE)
xx(REQUIRE)
xx(DIMENSION)
yy(COMMENT)
xx(ABORT)
yy(PRINT)
yy(PAUSE)
yy(NOTE)
yy(NOTE1)
yy(NOTE2)
];
define operator_classes=[
zz(COMMA)
yy([,])
xx(OR, or_X)
yy([∨], or_X)
xx(AND, and_X)
yy([∧], and_X)
xx(NOT, not_X)
yy([¬], not_X)
zz(ORDER)
yy([=], seq_X)
yy([≠], sne_X)
yy([>], sgt_X)
yy([<], slt_X)
yy([≥], sge_X)
yy([≤], sle_X)
zz(ABS)
yy([|])
yy(VVVTRANS)
zz(ADD)
yy([+], plus_X)
yy([-], minus_X)
zz(MULT)
yy([.], vdot_X)
yy([*], times_X)
yy([/], sdiv_X)
yy([⊗], vcross_X)
yy(WRT, wrt_X)
yy(VVROT, vvrot_X)
zz(TRANS)
yy(→, →_X)
yy([↑], stos_X)
zz(VECTOR)
yy([#],, nomv_X)
yy(ORIENT, orient_X)
yy(UNIT, uvect_X)
yy(AXIS, axis_X)
yy(POS, pos_X)
yy(INV, rinv_X)
zz(CLOSE_PAREN)
yy([)])
];
define require_definitions=[
xx(SOURCE_FILE)
xx(DELIMITERS)
xx(UNSTACK_DELIMITERS)
xx(REPLACE_DELIMITERS)
xx(MESSAGE)
xx(ERROR_MODES)
xx(SWITCHES)
xx(COMMENT_DELIMITERS)
xx(BAIL)
];
define move_definitions=[
xx(VIA)
xx(WITH)
xx(ARRIVAL)
yy(DEPARTURE)
xx(WOBBLE)
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
define
brace_RES =-1,
misc_RES =0,
cm_RES =0,
reserved_X_count=0,
statement_beg =reserved_X_count+1;
statement_definitions;
define
statement_end =reserved_X_count,
operator_beg =reserved_X_count+1;
operator_classes;
define
operator_end =reserved_X_count,
move_beg =reserved_X_count+1;
move_definitions;
define
move_end =reserved_X_count,
require_beg =reserved_X_count+1;
require_definitions;
define
require_end =reserved_X_count+1;
XX(METRIC) ! TIME, DISTANCE, etc.;
indices(require_definitions, _X);
indices(move_definitions, _X);
! miscellaneous reserved words;
define brace_definitions=[
zz(BRACE)
yy([}])
yy([{])
];
define cm_definitions=[
zz(cm)
qq(nil)
yy(FORCE, force_cm)
yy(TORQUE, torque_cm)
yy(FORCE_OR_TORQUE, force_or_torque_cm)
yy(DURATION)
yy(TEMPERATURE)
yy(SQUEEZE)
];
define metric_definitions=[
zz(METRIC)
qq(nil)
yy(DISTANCE, distance_METRIC)
yy(TIME, time_METRIC)
yy(MASS, mass_METRIC)
yy(ANGLE, angle_METRIC)
];
define misc_definitions=[
zz(MISC)
yy([?])
yy(ABS)
yy(TO)
yy(TRACING)
yy(WHERE)
yy(THEN)
yy(ENABLE)
yy(DISABLE)
yy(DO)
yy(FORM)
yy(AT)
yy(BY)
yy(CHANGING)
yy(ALSO)
yy(DONT)
yy(ONLY)
yy(RIGIDLY)
yy(NONRIGIDLY)
yy(STEP)
yy(UNTIL)
yy(ELSE)
];
redefine zz(str)=[];
redefine qq(str)=[
redefine qq_temp=[xx(str)];
qq_temp;];
redefine yy(str,str2)=[
redefine yy_temp=[xx(str)];
yy_temp;];
indices(metric_definitions, _METRIC);
define
metric_max =xxcount-1;
indices(cm_definitions, _CM);
define basic_dimensions=[
redefine zz(str,str2)=[];
redefine qq(str,str2)=[];
redefine yy(str,str2)=[xx(str)];
metric_definitions
];
! dec_name, declaration names for input and output;
! don't juggle the order of these definitions, because the parse will cease to
function;
define dec_name_definitions=[
xx(SCALAR, SVAR)
xx(VECTOR, VVAR)
xx(ROT, RVAR)
xx(FRAME, FVAR)
xx(PLANE, PVAR)
xx(TRANS, TVAR)
xx(EVENT, EVAR)
xx(ATOM, ATOM)
xx(WORLD, WVAR)
xx(CM_LABEL, ONLAB)
xx(CLC_LABEL, CLCLAB)
xx(CH_LABEL, CHGLAB)
xx(LABEL, STMLAB)
];
! data types;
DEFINE
form_VALUE =-1,
boole_VALUE =0; ! others follow directly;
define
dec_name_count=0;
redefine xx(in, out)=[
redefine dec_name_count=dec_name_count+1;
redefine xx_temp="define in" & "_VALUE=" & cvms(dec_name_count);
xx_temp;];
dec_name_definitions;
define frame_exp_VALUE=trans_VALUE; ! COERCION DICTATES THAT THESE BE THE SAME;
redefine xx(in, out)=["out",];
preload_array(
dec_name, dec_name_definitions, string, 1, dec_name_count);
! operators;
! ********** WARNING!!!!! **********
keep all entries marked TRUE contiguous
don't disturb the order of this table ;
define operator_definitions=[
XX(NOT, 1, FALSE, boole, boole, ignore)
XX(AND, 2, FALSE, boole, boole, ignore)
XX(OR, 2, FALSE, boole, boole, ignore)
XX(SEQ, 2, FALSE, boole, scalar, ignore)
XX(SNE, 2, FALSE, boole, scalar, ignore)
XX(SGT, 2, FALSE, boole, scalar, ignore)
XX(SLT, 2, FALSE, boole, scalar, ignore)
XX(SGE, 2, FALSE, boole, scalar, ignore)
XX(SLE, 2, FALSE, boole, scalar, ignore)
XX(UVECT, 1, FALSE, vector, vector, same)
XX(AXIS, 1, FALSE, vector, rot, ignore)
XX(POS, 1, FALSE, vector, trans, ignore)
XX(ORIENT, 1, FALSE, rot, trans, ignore)
XX(TMAKE, 2, TRUE, trans, boole, ignore)
XX(VMAKE, 3, TRUE, vector, scalar, ignore)
XX(FMAKE, 2, TRUE, trans, boole, ignore)
XX(VVTRANS, 3, TRUE, trans, scalar, ignore)
XX(SNEG, 1, TRUE, scalar, scalar, same)
XX(RINV, 1, TRUE, scalar, scalar, inverse)
XX(SABS, 1, TRUE, scalar, scalar, same)
XX([+], 2, TRUE, scalar, scalar, check, PLUS)
XX([-], 2, TRUE, scalar, scalar, check, MINUS)
XX([*], 2, TRUE, scalar, scalar, multiply, TIMES)
XX(WRT, 2, TRUE, scalar, scalar, multiply)
XX(ROT, 2, TRUE, vector, boole, ignore)
XX(→, 2, TRUE, trans, boole, divide)
XX(VDOT, 2, FALSE, scalar, vector, multiply)
XX(ANGLE, 2, FALSE, scalar, vector, ignore)
XX(VCROSS, 2, FALSE, vector, vector, multiply)
XX(VVROT, 2, FALSE, rot, vector, ignore)
XX(SDIV, 2, FALSE, scalar, scalar, divide)
XX(STOS, 2, FALSE, scalar, scalar, ignore)
XX(NOMV, 1, FALSE, form, form, same)
];
define
first_true_op=-1,
op_count=0;
redefine xx(str1, i1, boole, i2, i3, i4, str2)=[
redefine op_count=op_count+1;
ifc "str2"=null
thenc redefine xxtemp=[define str1] & "_X=op_count";
elsec redefine xxtemp=[define str2] & "_X=op_count";
endc
xxtemp;
ifc first_true_op<0 and boole
thenc redefine first_true_op=op_count; endc];
operator_definitions;
define zap_op(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str1, i1, boole, i2, i3, i4, str2)=[arg,];
elsec redefine xx(str1, i1, boole, i2, i3, i4, str2)=
[arg]&[postfix,];
endc
preload_array(name, operator_definitions, type, 1, op_count)];
zap_op(
op_array, string, "str1");
zap_op(
op_num, integer, i1);
zap_op(
op_bool, boolean, boole);
zap_op(
result_type, integer, i2, _VALUE);
zap_op(
type_of_args, integer, i3, _VALUE);
! specifies how to work out new DIMENSION of argument ;
define
ignore_dimen =0,
same_dimen =1,
inverse_dimen =2,
check_dimen =3,
multiply_dimen =4,
divide_dimen =5;
zap_op(
dimen_changes, integer, i4, _dimen);
! reserved_words;
define reserved_definitions=[
brace_definitions
cm_definitions
statement_definitions
operator_classes
require_definitions
metric_definitions
move_definitions
misc_definitions
];
define
reserved_count=0;
redefine zz(name)= [];
redefine qq(name)= [];
redefine xx(name)=[
redefine reserved_count=reserved_count+1;];
redefine yy(name, special)=[
redefine reserved_count=reserved_count+1;];
reserved_definitions;
redefine xx(name)=["name",];
redefine yy(name,special)=["name",];
preload_array(
reserved_words, reserved_definitions, string, 1, reserved_count);
redefine zz(name)=[
redefine class=["name"];
];
redefine xx(name)=[
redefine xxtemp=[name] & "_RES";
redefine class=["name"];
xxtemp,];
redefine yy(name,special)=[
redefine yytemp= class &"_RES";
yytemp,];
preload_array(
reserved_class, reserved_definitions, integer, 1, reserved_count);
redefine xx(name)=[0,];
redefine yy(name, special)=[
ifc "special"=null thenc 0 elsec special endc,];
preload_array(
reserved_special, reserved_definitions, integer, 1, reserved_count);
string array
reserved[0:hasher-1];
integer array
com_type[0:hasher-1];
! init_reserved;
forward INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
procedure init_reserved;
α string s; integer i, k;
boolean procedure find_sym(string s; reference integer k);
α string probe;
k ← hash(s, hasher);
while (probe ← reserved[k])≠null do
if equ(s, probe) then return(true) else k ← (k+1) mod hasher;
return(false);
β;
arrclr(reserved); arrclr(com_type);
for i ← 1 step 1 until reserved_count do
if find_sym(reserved_words[i], k)
then outstr(reserved_words[i] & " doubly defined!" & crlf)
else
α
reserved[k] ← reserved_words[i];
com_type[k] ← reserved_class[i]+reserved_special[i]*hasher;
β;
β;
require init_reserved initialization [0];
! predefined constants;
define constant_definitions=[
XX(GARB_ID, scalar, nil) ! do not move this entry;
XX(PI, scalar, nil)
XX(CM, scalar, distance)
XX(SEC, scalar, time)
XX(GM, scalar, mass)
XX(DEG, scalar, angle)
XX(XHAT, vector, nil)
XX(YHAT, vector, nil)
XX(ZHAT, vector, nil)
XX(NILVECT, vector, nil)
XX(NILROTN, rot, nil)
XX(NILTRANS, trans, nil)
XX(STATION, trans, distance)
XX(YPARK, trans, distance)
XX(BPARK, trans, distance)
XX(YARM, trans, distance)
XX(BARM, trans, distance)
XX(YHAND, scalar, distance)
XX(BHAND, scalar, distance)
XX(TRUE, boole, nil)
XX(FALSE, boole, nil)
];
define
const_count = 0;
redefine xx(str, i1, i2)=[redefine const_count = const_count+1;];
constant_definitions;
define zap_const(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str, i1, i2)=[arg,];
elsec redefine xx(str, i1, i2)=[arg] & [postfix,];
endc
preload_array(name, constant_definitions, type, 1, const_count)];
zap_const(
preconst, string, "str");
zap_const(
preconst_type, integer, i1, _VALUE);
zap_const(
pre_dimens, integer, i2, _METRIC);
! compiler switches and control tables;
! As the AL compile time system runs, several intermediate files are created
and destroyed. The default extensions of these files are listed below.
.AL user the ALGOL like AL source language
.LOG user file of errors detected by the PARSER
.SEX AL s-expression version of AL source code
.ALP (.AL0) ALC pseudo code
.ALT (.AL1) ALC trajectory file
.ALV (.AL2) ALC constants and variable definitions for pseudo code
.ALS (.AL3) ALC symbol table usable by the PDP-11 runtime system
.ALL ALC hybrid s-expression/real AL listing
.LST PALX PDP-11 assembly code listing
.BIN PALX PDP-11 binary file loaded by 11TTY
.DMP 11TTY PDP-11 core image
;
! compiler switches;
define compiler_switches=[
xx(K, false) ! keep extraneous intermediate files: .ALP, .ALV, .ALT;
xx(S, false) ! inhibit the deletion of the .SEX file;
xx(L, false) ! generate a PALX assembly listing;
xx(B, false) ! run BAIL immediately after scanning the command line;
xx(E, false) ! load the .BIN file into the PDP-11;
];
indices(compiler_switches, _X);
define
switch_max =xxcount-1;
redefine xx(name, default)=["name",]; preload_array(
switch_name, compiler_switches, string, 0, switch_max+1);
redefine xx(name, default)=[default,]; preload_array(
switch_default, compiler_switches, boolean, 0, switch_max+1);
boolean array
switch_setting[0:switch_max];
procedure preset_switches;
α integer i;
for i ← 0 step 1 until switch_max do switch_setting[i] ← switch_default[i];
β;
require preset_switches initialization[0];
! hash, declaration of debugging variables, start of hidden_parse;
INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
α INTEGER I,TOT,C;
C←I←1; TOT←0;
WHILE I≠0 DO TOT←TOT+(C←C+1)*(I←LOP(S));
RETURN(TOT MOD MAX);
β;
ifc debug_compile thenc ! some variables that can be used for debugging;
require "BREAK.HDR[1,PJ]" source_file;
record_pointer(any_class)
__r0, __r1, __r2, __r3, __r4, __r5, __r6, __r7, __r8, __r9;
string
__s0, __s1, __s2, __s3, __s4, __s5, __s6, __s7, __s8, __s9;
integer
__i0, __i1, __i2, __i3, __i4, __i5, __i6, __i7, __i8, __i9;
real
__x0, __x1, __x2, __x3, __x4, __x5, __x6, __x7, __x8, __x9;
procedure debug_init;
α
__r0 ← __r1 ← __r2 ← __r3 ← __r4 ← __r5 ← __r6 ← __r7 ← __r8 ← __r9 ← null_record;
__s0 ← __s1 ← __s2 ← __s3 ← __s4 ← __s5 ← __s6 ← __s7 ← __s8 ← __s9 ← null;
__i0 ← __i1 ← __i2 ← __i3 ← __i4 ← __i5 ← __i6 ← __i7 ← __i8 ← __i9 ← 0;
__x0 ← __x1 ← __x2 ← __x3 ← __x4 ← __x5 ← __x6 ← __x7 ← __x8 ← __x9 ← 0.0;
β;
require debug_init initialization[0];
endc
! The following (making all of parse a recursive procedure) is a hack to get the
restart option to work properly. As soon as a better way is found of
making sure everything gets reinitialized properly, this should be taken
out;
recursive procedure hidden_parse;
α "hidden_parse"
! ---- DECLARATIONS ----;
external integer
rpgsw;
record_pointer(file)
AL_file, ! AL source file;
SEX_file, ! s-expression file;
BIN_file, ! PALX binary file;
ALL_file, ! ALC listing file;
LOG_file; ! LOG listing file;
BOOLEAN
DISK, ! TRUE IF INPUT IS COMING FROM DISK;
AUTO_PROCEED, ! TRUE IF AUTO_PROCEED SWITCH IS ON FOR ERROR RECOVERY;
LOGGING, ! TURE IF LOGGING WANTED;
COMPILE_LOGGING,
log_file_open,
strict_dimen_check;
STRING
cmd_line,
INFILE,
OUTFILE, ! INPUT,OUTPUT & LOG FILES;
LOGFILE;
INTEGER
CHANIN,
CHANOUT,
CHANLOG;
STRING
INSTRING, ! INPUT STRING;
TABLE1; ! BREAK TABLES;
INTEGER
TYPE_OF_TOKEN;
define
special_token =0,
id_token =1,
numeric_token =2,
string_token =3;
integer
TYPE_OF_RES_WORD, ! TYPE PULLED OFF OF COM_TYPE;
SPECIAL_INFO, ! INFO PASSED FROM SCANNER TO PARSER - DEPENDS ON TYPE;
word_R_break, ! break tables;
non_blank_break,
word_S_break,
close_brace_break,
non_digit_break,
quote_break,
macro_delimiter_break,
semicolon_A_break,
cr_break,
paren_cr_break,
lf_ff_break,
semicolon_R_break,
omit_break;
STRING
TOKEN,
CURRENT_FRAME; ! TOKEN OF THE CURRENT FRAME - DEFAULT SET TO "YARM";
INTEGER
SPACING; ! SPACING FOR OUTPUT;
BOOLEAN
REJECT; ! TRUE WHEN THE LAST TOKEN IS REJECTED BY THE CALLING PROC;
INTEGER
DEC_NUM; ! THE NUMBER OF DECLARATIONS IN THE CURRENT BLOCK;
STRING
OUTEXPR; ! FOR THE CONSTRUCTION OF THE STRING FOR EXPRESSIONS;
STRING
OPEN_BRACE;
! record declarations;
RECORD_CLASS
PARAM_LIST(
STRING
ID,
USER_ID;
RECORD_POINTER(PARAM_LIST)
NEXT
);
RECORD_CLASS
MACRO_LIST(
STRING
VALUE, ! ACTUAL MACRO body;
ID,
DELIMITERS;
INTEGER
NUM; ! NUMBER OF PARAMETERS;
RECORD_POINTER(MACRO_LIST)
NEXT, ! POINTS TO NEXT MACRO WHICH HASHES TO THE SAME ENTRY;
LAST, ! BACK POINTER IN THE SAME LIST;
LINK; ! USED ONLY FOR PARAMETER EXPANSION, POINTS TO THE
PARAMETER DEFINED JUST BEFORE THIS ONE;
RECORD_POINTER(PARAM_LIST)
PARAMS
);
RECORD_POINTER(MACRO_LIST)
TOP_PARAM,
current_macro,
CUR_MACRO;
RECORD_POINTER(MACRO_LIST) ARRAY
MACRO_TABLE[0:hasher];
RECORD_CLASS
DELIMITER_LIST(
STRING
D1,
D2;
RECORD_POINTER(DELIMITER_LIST)
NEXT
);
RECORD_POINTER(DELIMITER_LIST)
TOP_DELIMITERS;
RECORD_CLASS
MACRO_STACK(
RECORD_POINTER(MACRO_LIST)
LIST_PTR;
RECORD_POINTER(MACRO_STACK)
STACK_LINK
);
RECORD_POINTER(MACRO_STACK)
MACRO_STACK_TOP,
MACRO_ST2;
RECORD_CLASS
MACRO_CONCATENATE_LIST(
RECORD_POINTER(MACRO_LIST)
MACRO_PTR;
RECORD_POINTER(MACRO_CONCATENATE_LIST)
NEXT
);
RECORD_POINTER(MACRO_CONCATENATE_LIST)
MACRO_CON_HEAD;
RECORD_CLASS
DIMENS_EXPONENT(
STRING
NAME;
INTEGER
DISTANCE,
TIME, ! GIVES EXPONENTS OF VARIOUS COEFFICIENTS;
MASS,
ANGLE;
RECORD_POINTER(DIMENS_EXPONENT)
NEXT,
LAST
);
RECORD_POINTER(DIMENS_EXPONENT)
NIL_DIMENS,
DISTANCE_DIMENS, ! WILL HOLD DIMENS LIST FOR DISTANCE -- NEEDED FOR ⊗;
TIME_DIMENS,
MASS_DIMENS,
ANGLE_DIMENS, ! WILL HOLD DIMENS LIST FOR ANGLES -- NEEDED FOR ROT;
EXP_DIMENS;
RECORD_POINTER(DIMENS_EXPONENT) ARRAY
DIMENS_TABLE[0:hasher],
D_TABLE[0:metric_max];
RECORD_CLASS
ID_LIST(
STRING
NAME;
INTEGER
TYPE;
RECORD_POINTER(ID_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LINK; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
BOOLEAN
LABEL_USED;
RECORD_POINTER(DIMENS_EXPONENT)
DIMEN;
INTEGER
BLOCK_LEVEL_OF_DEFN
);
RECORD_POINTER(ID_LIST) ARRAY
SYMBOL_TABLE[0:hasher];
RECORD_POINTER(ID_LIST)
TOP_ID;
RECORD_CLASS
EXPR(
INTEGER
TYPE;
STRING
OP,
ID;
RECORD_POINTER(DIMENS_EXPONENT)
DIMEN;
RECORD_POINTER(ANY_CLASS)
PARTS
);
RECORD_POINTER(EXPR)
EXP1,
EXP2,
EXP3;
RECORD_CLASS
EXPR_LIST(
RECORD_POINTER(EXPR)
EXP;
RECORD_POINTER(EXPR_LIST)
NEXT
);
RECORD_POINTER(EXPR_LIST)
EXPRS,
EXPRSAVE;
RECORD_CLASS
OP_LIST(
RECORD_POINTER(OP_LIST)
NEXT;
INTEGER
PRIORITY,
OP,
NUM_OF_ARGS,
COUNT;
BOOLEAN
ARG_DEP,
FUNC
);
RECORD_POINTER(OP_LIST)
OPS,
OPSAVE;
RECORD_CLASS
SOURCE_LIST(
INTEGER
CHAN, ! i/o CHANNEL NUMBER OF input, -1 if from macro;
NUM; ! NUMBER OF PARAMETERS IN THE CURRENT MACRO;
STRING
CUR_STRING, ! curline WHEN PUSHED;
CUR_STRINGR, ! curliner WHEN PUSHED;
FILE_NAME; ! NAME OF THE INPUT FILE WHEN PUSHED;
RECORD_POINTER(SOURCE_LIST)
NEXT;
RECORD_POINTER(MACRO_STACK)
MACRO_STACK_TOP;
RECORD_POINTER(MACRO_LIST)
CUR_MACRO;
INTEGER
PN,
LN ! PAGE AND LINE NUMBER OF THE PUSHED FILE;
);
RECORD_POINTER(SOURCE_LIST)
TOP_SOURCE;
! other declarations;
INTEGER
EXP_TYPE; ! TYPE OF EXPRESSION FOUND BY P_EXP;
BOOLEAN
PLAN_STATEMENT; ! TRUE IF CURRENT STATMENT IS PREFIXED BY PLAN;
STRING
CHANGER_HEAD; ! NON NULL IF PARSING A STATEMENT INSDIDE A CHANGER;
INTEGER
T_COUNT; ! COUNTER FOR PRODUCING UNIQUE ID'S;
BOOLEAN
OP_EXPECTED; ! TRUE WHEN P_EXP EXPECTS AN OPERATION;
INTEGER
DELIMITER_1, ! non-zero only while defining macro;
DELIMITER_2; ! HEAD AND TAIL DELIMITER OF macro bodies;
INTEGER
MAC_NUM; ! NUMBER OF PARAMS IN THE CURRENT MACRO EXPANSION;
INTEGER
BLOCK_LEVEL;
! GARBAGE DECLARATIONS (VERY LOCAL);
BOOLEAN
T,
EOF;
INTEGER
COUNT,
I,
N,
BRCHAR;
STRING
GARB;
INTEGER
LINENUM,
PAGENUM,
SOSNUM,
typed_page_num, ! on tty;
sourcelvl;
STRING
CURLINER,
CURLINE;
! error, error_recovery, error_reject, print, file_indent;
FORWARD RECURSIVE PROCEDURE P_STATEMENT;
forward procedure add_to_table1(string s);
FORWARD RECURSIVE PROCEDURE GET_TOKEN;
FORWARD PROCEDURE OPEN_LOGGING_FILE;
forward RECORD_POINTER (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
forward RECORD_POINTER (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S;
INTEGER TABLE_TYPE; RECORD_POINTER(ANY_CLASS) RR1(NULL_RECORD));
forward boolean procedure got_output(record_pointer(file) F);
RECORD_POINTER(ANY_CLASS) PROCEDURE ERROR(INTEGER I;STRING S);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE ERROR FACILITY MORE VERSATILE;
! I don't understand the error number stuff. All errors numbered 200
have been added by me and can be arbitrarily reassigned.
PJ 8/30/76;
α INTEGER L1,L2; BOOLEAN PROCEED; INTEGER COMMAND_CHAR;
RECORD_POINTER(ANY_CLASS) PROCEDURE ERROR_RECOVERY(INTEGER I);
IF I=13 THEN α RECORD_POINTER(ID_LIST)D1;
OUTSTR(CRLF& "Continue will declare it internally");
D1←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[D1]←TRANS_VALUE;
ID_LIST:BLOCK_LEVEL_OF_DEFN[D1]←BLOCK_LEVEL;
RETURN(D1);
β
ELSE
IF I=55 THEN α string s; s←null;
WHILE LENGTH(S)=0 AND ¬AUTO_PROCEED DO α
OUTSTR(CRLF& "Type in correct file"&crlf& "*");
s←inchwl; PROCEED←TRUE;
if length(s)≠0 then infile←s;
β;
RETURN(NULL_RECORD);
β
ELSE
RETURN(NULL_RECORD);
RECORD_POINTER(ANY_CLASS) C1;
string source_pos;
STRING LINE,LINER;
source_pos←"File "& INFILE& ", Page "& CVS(PAGENUM+1)& ", Line "& CVS(LINENUM);
LINE←CURLINE; LINER←CURLINER;
IF CHANIN≤-1 THEN α ! SUBSTITUTE DUMMY PARAMETERS OF MACRO FOR REAL THING;
INTEGER I1,PARAM_COUNT;
source_pos← "At "&source_pos&crlf&"inside Macro "¯o_list:id[current_macro];
if liner=space then liner←liner[2 to ∞];
IF (PARAM_COUNT←SOURCE_LIST:NUM[TOP_SOURCE]) > 0
THEN α
string array param_id,param_arg[1:param_count];
record_pointer(param_list) param_ptr;
integer l1,l2,temp;
string t;
string procedure subst(string old_string);
α string t,t1,old;
integer brchar,i1;
old←old_string;
t←scan(old,temp,brchar);
while brchar≠0 do
α t1←old[1 to l1];
old←old[l2 to ∞];
for i1←1 step 1 until param_count do
if equ(t1,param_arg[i1])
then t←t¶m_id[i1];
t←t&scan(old,temp,brchar);
β;
return(t);
β;
param_ptr←macro_list:params[current_macro];
source_pos←source_pos&"(";
for i1←1 step 1 until param_count do
α param_arg[i1]←param_list:id[param_ptr];
param_id[i1]←param_list:user_id[param_ptr];
param_ptr←param_list:next[param_ptr];
source_pos←source_pos¶m_id[i1]&",";
β;
l1←length(source_pos);
source_pos←source_pos[1 to l1-1]&")"&crlf;
l2←(l1←length(param_arg[1]))+1;
t←param_arg[1][1 for 1];
setbreak(temp←getbreak,t,null,"INR");
line←subst(line);
liner←subst(liner);
RELBREAK(TEMP);
β;
β;
WHILE EQU(LINE[1 TO 1], lf) DO GARB←LOP(LINE);
L1←LENGTH(LINER); L2←LENGTH(LINE)-L1; PROCEED←AUTO_PROCEED;
OUTSTR(crlf & "YOU LOOSE - ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
C1←ERROR_RECOVERY(I);
IF ¬LOGGING THEN IF COMPILE_LOGGING THEN OPEN_LOGGING_FILE;
IF LOGGING THEN
OUT(CHANLOG,crlf & "YOU LOOSE - ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
WHILE ¬PROCEED DO
α
CLRBUF; OUTSTR("↑"); COMMAND_CHAR←INCHRW;
IF COMMAND_CHAR="B" THEN
α
OUTSTR("ail" & crlf);
IFC debug_compile
THENC BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β
ELSE IF COMMAND_CHAR=cr THEN
α CLRBUF; PROCEED←TRUE; β
ELSE IF COMMAND_CHAR=lf THEN
α PROCEED←TRUE; AUTO_PROCEED←TRUE; β
ELSE IF COMMAND_CHAR="A" THEN
α OUTSTR("utomatic continuation");
IF LOGGING THEN OUTSTR(" and logging");
OUTSTR(".");
PROCEED←TRUE; AUTO_PROCEED←TRUE;
β
ELSE IF COMMAND_CHAR="E" THEN
α OUTSTR("dit" & crlf);
CLOSO(CHANLOG);
EDFILE(INFILE,LINENUM,PAGENUM+1,0);
β
ELSE IF COMMAND_CHAR="R" THEN
α
OUTSTR("estart"); CURLINE←CURLINER←null;
USERERR(0,1,NULL,"S"); ! THIS IS A HACK AND SHOULD BE CHANGED
AS SOON AS POSSIBLE;
β
ELSE IF COMMAND_CHAR="X" THEN
α OUTSTR("it" & crlf);
USERERR(0,1,NULL,"X"); ! DITTO ABOVE COMMENT;
β
ELSE IF (COMMAND_CHAR="L" AND LOGGING≠TRUE) THEN
α
OPEN_LOGGING_FILE;
OUT(CHANLOG,crlf & "YOU LOOSE - ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & LINE[1 TO L2] & lf & LINER & crlf);
OUTSTR("ogging in file name " & LOGFILE & crlf );
β
ELSE α
OUTSTR("Reply [CR] to continue," & crlf &
"[LF] or ""A"" to continue automatically," & crlf &
"""E"" to edit source file," & crlf &
"""R"" to restart," & crlf &
"""X"" to exit");
IFC DEBUG_COMPILE THENC OUTSTR("," & crlf & """B"" to load Bail"); ENDC
IF ¬LOGGING THEN OUTSTR("," & crlf & """L"" for logging");
OUTSTR("." & crlf);
β;
β;
RETURN(C1);
β;
PROCEDURE ERROR_REJECT(INTEGER I;STRING S);
α ERROR(I,S); REJECT←TRUE; β;
PROCEDURE PRINT(STRING S);
α
ifc debug_compile thenc
INTEGER I,J,K,L;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
J←LENGTH(S);
WHILE J>80 DO
α;
K←80;
WHILE K≤J AND ¬EQU(S[K TO K]," ") DO K←K+1;
OUT(CHANOUT,S[1 TO K] & crlf);
S←S[K+1 TO J];
J←J-K;
β;
OUT(CHANOUT,S & crlf)
elsec
INTEGER I;
FOR I←1 STEP 1 UNTIL SPACING DO OUT(CHANOUT," ");
OUT(CHANOUT,S & crlf);
endc;
β;
procedure file_indent(integer i);
α
typed_page_num ← false;
outstr(" "[1 for 2*i]);
β;
! read, push_macro_delimiters;
STRING PROCEDURE READ(INTEGER BTABLE);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE READING FACILITY MORE VERSATILE;
α STRING TEXT;
text ← SCAN(CURLINER,BTABLE,BRCHAR);
WHILE BRCHAR=0 DO
α BOOLEAN REPLACED;
REPLACED←TRUE;
IF CHANIN>-1 THEN α
IF CHANIN≤15 THEN CURLINE←CURLINER←INPUT(CHANIN,lf_ff_break);
macro_stack_top←macro_st2;
β;
IF CHANIN≤-1 THEN
α "pop macro"
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←" "&SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
macro_st2←SOURCE_LIST:macro_stack_TOP[TOP_SOURCE];
CURRENT_MACRO←SOURCE_LIST:CUR_MACRO[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β "pop macro"
ELSE IF BRCHAR=lf THEN LINENUM←LINENUM+1
ELSE IF BRCHAR=ff THEN
α
outstr(" " & cvs((PAGENUM←PAGENUM+1)+1));
typed_page_num ← true; LINENUM←0
β
ELSE IF TOP_SOURCE≠NULL THEN
α "close_source"
IF CHANIN ≤ 15 then RELEASE(CHANIN);
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
INFILE←SOURCE_LIST:FILE_NAME[TOP_SOURCE];
CURRENT_MACRO←NULL_RECORD;
MAC_NUM←SOURCE_LIST:NUM[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
outstr(crlf); typed_page_num ← false; sourcelvl ← sourcelvl-1;
β "close_source"
ELSE IF EOF THEN ERROR(500,"end of file encountered unexpectedly.");
TEXT ← TEXT & SCAN(CURLINER,BTABLE,BRCHAR);
β;
RETURN(TEXT);
β;
procedure push_delimiters(string s);
α record_pointer(delimiter_list) new_del;
DELIMITER_LIST:NEXT[NEW_DEL ← new_record(delimiter_list)] ← TOP_DELIMITERS;
DELIMITER_LIST:D1[NEW_DEL] ← lop(s); DELIMITER_LIST:D2[NEW_DEL] ← lop(s);
TOP_DELIMITERS←NEW_DEL;
β;
! macro handling routine;
BOOLEAN procedure macro_handler;
α "macro_handler"
INTEGER HASH_ENTRY; STRING MACRO_NAME;
INTEGER PARAM_COUNT;
BOOLEAN SPECIAL_DELIMS; RECORD_POINTER (MACRO_LIST) MAC_POINT;
RECORD_POINTER (PARAM_LIST) TOP_PARAM, NEW_PARAM, LAST_PARAM;
BOOLEAN STATUS;
LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER PP,IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
STATUS←FALSE;
GOTO FLUSH;
β;
procedure macro_delimiters(boolean turn_on);
α string chr1, chr2;
if turn_on
then if top_delimiters≠null_record
then
α
chr1 ← delimiter_list:d1[top_delimiters];
chr2 ← delimiter_list:d2[top_delimiters];
β
else chr1 ← chr2 ← dquote
else chr1 ← chr2 ← null;
delimiter_1 ← chr1; delimiter_2 ← chr2;
SETBREAK(macro_delimiter_break, chr1 & chr2, NULL, "ISN");
SETBREAK(word_R_break, TABLE1 & chr1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1 & chr1, NULL, "INSK");
β;
STATUS←TRUE;
do α "define_macro"
SPECIAL_DELIMS←FALSE; PARAM_COUNT←0; GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN F_STATE(0,56,"Can only define unreserved ID's.");
MACRO_NAME←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"(") THEN
α "macro_parameters"
TOP_PARAM←LAST_PARAM←NEW_RECORD(PARAM_LIST);
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN F_STATE(0,57,"Can only use unreserved ID's as parameter names.");
PARAM_COUNT←PARAM_COUNT+1; NEW_PARAM←NEW_RECORD(PARAM_LIST);
PARAM_LIST:NEXT[LAST_PARAM]←NEW_PARAM;
PARAM_LIST:USER_ID[NEW_PARAM]←TOKEN; LAST_PARAM←NEW_PARAM;
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
α
ERROR(58,"Need either comma or right paren here.");
REJECT←TRUE; TOKEN←")";
β;
β;
TOP_PARAM←PARAM_LIST:NEXT[TOP_PARAM];
GET_TOKEN;
β "macro_parameters"
ELSE TOP_PARAM←LAST_PARAM←NULL_RECORD;
IF TYPE_OF_TOKEN=string_token THEN
α "special_delimiters" RECORD_POINTER (DELIMITER_LIST) NEW_DEL;
SPECIAL_DELIMS←TRUE;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2 THEN F_STATE(0,53,"Need string of length 2.");
push_delimiters(token);
β "special_delimiters";
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(59,"Need = here.");
macro_delimiters(true); GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,60,"Need string here.")
ELSE
α
! bind macros;
if param_count>0 then
α "PARAMS"
string array param_id, param_arg[1:param_count];
integer i,width,digits;
string t1;
string t, processed_token;
STRING BREAK_STRING;
string t2;
record_pointer(param_list) param_ptr;
param_ptr←top_param;
BREAK_STRING←NULL;
GETFORMAT(WIDTH,DIGITS);
SETFORMAT(-2,0);
if chanin>0 then t1←"00" else t1←cvs(abs(chanin));
for i ← 1 step 1 until param_count do
α
param_id[i]←param_list:user_id[param_ptr];
param_arg[i]←(param_list:id[param_ptr]← "∀∀∀∀__"& t1 & "__"&cvs(i));
param_ptr←param_list:next[param_ptr];
β;
SETFORMAT(WIDTH,DIGITS);
processed_token← NULL;
SETBREAK(word_S_break, TABLE1 & delimiter_1 & delimiter_2, NULL, "INSK");
do α
integer brchar,brchar2;
t2←scan(token,non_blank_break,brchar);
if t2≠null then processed_token←processed_token&t2;
t←scan(token,word_s_break,brchar2);
if t≠null then
α for i←1 step 1 until param_count do
if equ(t,param_id[i]) then t←param_arg[i];
processed_token←processed_token&t;
β;
if brchar2≠null then processed_token←processed_token&brchar2;
β until length(token)=0;
token←processed_token;
β "PARAMS";
! done binding macros;
β;
macro_delimiters(false);
if chanin≤-1
then mac_point←insert_entry(macro_name,macro_in_macro_type_table)
else mac_point←insert_entry(macro_name,macro_type_table);
MACRO_LIST:VALUE[MAC_POINT]←TOKEN;
MACRO_LIST:NUM[MAC_POINT]←PARAM_COUNT;
MACRO_LIST:PARAMS[MAC_POINT]←TOP_PARAM;
IF top_delimiters≠null then
MACRO_LIST:DELIMITERS[MAC_POINT]←delimiter_list:d1[top_delimiters]
& delimiter_list:d2[top_delimiters];
IF SPECIAL_DELIMS THEN
α
IF NULL=TOP_DELIMITERS
THEN F_STATE(0,54,"Can't unstack special delimiters!");
TOP_DELIMITERS←DELIMITER_LIST:NEXT[TOP_DELIMITERS];
β;
get_token;
β "define_macro"
until ¬equ(token, ",");
if equ(token, ";") then reject ← true;
FLUSH: RETURN(STATUS);
β "macro_handler";
! expand_macro;
RECURSIVE PROCEDURE EXPAND_MACRO;
α record_pointer(macro_list) m1;
RECORD_POINTER(MACRO_CONCATENATE_LIST) C1;
STRING PROCESSED_BODY,D1,D2;
RECORD_POINTER(SOURCE_LIST)NEW_SOURCE2;
PROCESSED_BODY←NULL;
NEW_SOURCE2←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CHAN[NEW_SOURCE2]←CHANIN;
SOURCE_LIST:CUR_MACRO[NEW_SOURCE2]←CURRENT_MACRO;
CURRENT_MACRO←CUR_MACRO;
c1←MACRO_CON_HEAD;
do α "expand macro"
STRING MAC_ID; RECORD_POINTER(PARAM_LIST) PARAMS;
STRING BODY;
INTEGER BRCHAR2;
M1←MACRO_CONCATENATE_LIST:MACRO_PTR[C1];
PARAMS←MACRO_LIST:PARAMS[M1];
MAC_ID←MACRO_LIST:ID[M1];
D1←MACRO_LIST:DELIMITERS[M1][1 FOR 1];
D2←MACRO_LIST:DELIMITERS[M1][2 FOR 1];
GET_TOKEN;
IF ¬EQU(TOKEN,"(") AND PARAMS≠NULL
THEN ERROR(59,"Parametered macro used without params.")
ELSE IF ¬EQU(TOKEN,"(")
THEN
α
CURLINER←TOKEN&CURLINER;
BODY←MACRO_LIST:VALUE[M1];
β
ELSE
α "macro parameters"
STRING T,t2r,t3;
FOR I←1 STEP 1 UNTIL MACRO_LIST:NUM[M1] DO
α RECORD_POINTER(MACRO_LIST)SUB_MACRO;
IF EQU(TOKEN,")") THEN
ERROR(60,"Number of parameters disagree with definition.");
GET_TOKEN;
! IF TYPE_OF_TOKEN≠string_token THEN
ERROR(61,"Need a string here.");
SUB_MACRO←INSERT_ENTRY(PARAM_LIST:ID[PARAMS],MACRO_IN_MACRO_TYPE_TABLE);
MACRO_LIST:VALUE[SUB_MACRO]←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(62,"NEED EITHER COMMA OR RIGHT PAREN HERE.");
PARAMS←PARAM_LIST:NEXT[PARAMS];
β;
IF ¬EQU(TOKEN,")") THEN ERROR(62,"Number of parameters don't match the defn.");
body←macro_list:value[m1];
β "macro parameters";
PROCESSED_BODY←processed_body&body;
β "expand macro" until (c1←macro_concatenate_list:next[c1])=NULL_record;
SOURCE_LIST:NUM[NEW_SOURCE2]←MACRO_LIST:NUM[M1];
SOURCE_LIST:NEXT[NEW_SOURCE2]←TOP_SOURCE;
SOURCE_LIST:CUR_STRING[NEW_SOURCE2]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE2]←CURLINER;
SOURCE_LIST:PN[NEW_SOURCE2]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE2]←LINENUM;
SOURCE_LIST:MACRO_STACK_TOP[NEW_SOURCE2]←MACRO_STACK_TOP;
IF CHANIN≥0 THEN CHANIN←-1 ELSE CHANIN←CHANIN-1;
CURLINE←CURLINER←processed_body;
TOP_SOURCE←NEW_SOURCE2;
GET_TOKEN;
WHILE EQU(TOKEN,"DEFINE") DO
α
macro_handler; get_token; GET_TOKEN;
β;
β;
! get_token;
! THIS PROCEDURE GETS THE NEXT TOKEN. PUTS THE TOKEN IN "TOKEN" THE TYPE OF
THE TOKEN IN "TYPE_OF_TOKEN";
RECURSIVE PROCEDURE GET_TOKEN;
α "get_token" BOOLEAN T; INTEGER POINT;
RECORD_POINTER(MACRO_LIST) PROCEDURE LOOK_FOR_MACRO;
α RECORD_POINTER (MACRO_LIST) R1;
IF MACRO_STACK_TOP≠NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_IN_MACRO_TYPE_TABLE);
IF R1=NULL
THEN R1←CHECK_ENTRY(TOKEN,MACRO_TYPE_TABLE);
RETURN(R1);
β;
IF REJECT THEN α REJECT←FALSE; RETURN; β;
TYPE_OF_TOKEN←special_token; T←TRUE;
WHILE T DO
α "while_T"
READ(non_blank_break); TOKEN←READ(word_R_break);
IF EQU(TOKEN,NULL) THEN
α "isolated break"
IF BRCHAR="."
THEN
α REAL NUM;
CURLINER←"0"&CURLINER;
if (NUM←REALSCAN(CURLINER,BRCHAR))≠0
THEN
α
TYPE_OF_TOKEN←numeric_token; TOKEN←CVG(NUM)
β
ELSE TOKEN←".";
β
ELSE IF BRCHAR="-" THEN
α REAL NUM;
garb ← LOP(CURLINER); CURLINER←"-0"&CURLINER;
if (NUM←REALSCAN(CURLINER,BRCHAR))≠0
THEN
α
TYPE_OF_TOKEN←numeric_token; TOKEN←CVG(NUM)
β
ELSE TOKEN←"-";
β;
IF EQU(TOKEN,NULL) THEN α READ(word_S_break); TOKEN←BRCHAR; β;
β "isolated break";
IF EQU(TOKEN,OPEN_BRACE) THEN TOKEN←READ(close_brace_break) ELSE T←FALSE;
β "while_T";
IF TOKEN=dquote THEN
α "found_string"
TOKEN←READ(quote_break); TYPE_OF_TOKEN←string_token;
while curliner=dquote do token ← token & lop(curliner) & read(quote_break);
RETURN;
β "found_string";
! delimiter_1 non-zero only while defining macro;
if delimiter_1 and token=delimiter_1 then
α "found_macro_body" integer lvl;
token←read(macro_delimiter_break); type_of_token ← string_token;
if delimiter_1=delimiter_2 ∨ brchar=delimiter_2 then return;
lvl ← 2; if brchar≠delimiter_1 then error(200, "macro body scan lost");
do α
token ← token & brchar & read(macro_delimiter_break);
if brchar=delimiter_2
then lvl ← lvl-1
else if brchar=delimiter_1
then lvl ← lvl+1
else error(200, "macro body scan lost");
β
until lvl ≤ 0;
return;
β "found_macro_body";
! look for reserved word;
IF TYPE_OF_TOKEN=special_token THEN
α
POINT←HASH(TOKEN,hasher);
WHILE ¬EQU(RESERVED[POINT],NULL) AND ¬EQU(RESERVED[POINT],TOKEN) DO
POINT←(POINT+1)MOD hasher;
IF RESERVED[POINT]=TOKEN
THEN
α "reserved word" INTEGER VAL;
TYPE_OF_TOKEN←special_token;
VAL←COM_TYPE[POINT];
IF VAL≥hasher
THEN
α
SPECIAL_INFO←(VAL DIV hasher);
TYPE_OF_RES_WORD←(VAL MOD hasher);
β
ELSE α SPECIAL_INFO←0; TYPE_OF_RES_WORD←VAL; β;
β "reserved word"
ELSE
α "not reserved"
IF ¬("0" ≤ token ≤ "9")
THEN α "MAC_TEST"
IF (CUR_MACRO←LOOK_FOR_MACRO)=NULL
THEN TYPE_OF_TOKEN←id_token
ELSE α "MACRO"
string ttoken;
record_pointer (macro_concatenate_list) ptr;
record_pointer(macro_list)r1;
PTR←(MACRO_CON_HEAD←NEW_RECORD(MACRO_CONCATENATE_LIST));
macro_concatenate_list:macro_ptr[ptr]←cur_macro;
read(non_blank_break); ttoken←read(word_R_break);
while ttoken= null and brchar="&"
do α
curliner←curliner[2 to ∞];
read(non_blank_break);
token←read(word_S_break);
if (r1←look_for_macro) = null
then α
error(1111, "Need macro name here.");
curliner←token&brchar&curliner;
β
else α
ptr←(macro_concatenate_list:next[ptr]←new_record(macro_concatenate_list));
macro_concatenate_list:macro_ptr[ptr]←r1;
read(non_blank_break);ttoken←read(word_r_break);
β;
β;
curliner←ttoken&curliner;
EXPAND_MACRO;
β "MACRO";
β "MAC_TEST"
ELSE
α "numeric" REAL NUM1,NUM2; INTEGER NUMGARB;
TYPE_OF_TOKEN←numeric_token;
NUM1←INTSCAN(TOKEN,NUMGARB);
IF ¬EQU(TOKEN,NULL) THEN ERROR(0,"Illegal token." &
crlf & "Garbage after digits will be ignored.");
IF BRCHAR="."
THEN
α
CURLINER←"0"&CURLINER;
NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1+NUM2);
β
ELSE IF BRCHAR="@"
THEN
α
CURLINER←"1"&CURLINER;
NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1*NUM2);
β
ELSE TOKEN←CVG(NUM1);
β "numeric";
β "not reserved";
β;
β "get_token";
! check, inverse, multiply and divide dimensions;
RECORD_POINTER(DIMENS_EXPONENT)
PROCEDURE CHECK_DIMENSIONS(STRING S; REFERENCE RECORD_POINTER(DIMENS_EXPONENT) D1,D2);
α RECORD_POINTER(DIMENS_EXPONENT)II1,II2,II3;STRING SS;BOOLEAN SAME;
SS←NULL;
SAME←TRUE;
II1←D1; II2←D2;
IF II1≠II2 THEN
α IF II1=NULL_RECORD THEN II1←NIL_DIMENS;
IF II2=NULL_RECORD THEN II2←NIL_DIMENS;
redefine xx(temp)= [ IF DIMENS_EXPONENT:temp[II1]≠DIMENS_EXPONENT:temp
[II2] THEN α IF LENGTH(SS)≠0 THEN SS←SS&", temp " ELSE SS←" temp ";
SAME←FALSE;β;];
IF STRICT_DIMEN_CHECK OR ((II2≠NIL_DIMENS) AND (II1≠NIL_DIMENS))
THEN α BASIC_DIMENSIONS;
IF SAME THEN II3←II1
ELSE ERROR(122, SS & "Dimensions don't match on "&S&".");
β
ELSE IF II1≠NIL_DIMENS THEN II3←II1 ELSE II3←II2;
β
ELSE IF II1=NULL_RECORD THEN II3←NIL_DIMENS ELSE II3←II1;
IF SAME THEN RETURN(II3);
β;
RECORD_POINTER(DIMENS_EXPONENT)
PROCEDURE INVERSE_DIMENSIONS(RECORD_POINTER(DIMENS_EXPONENT)D2);
α
RECORD_POINTER(DIMENS_EXPONENT) D1;
IF D2≠NULL_RECORD THEN
α
RECORD_POINTER(DIMENS_EXPONENT) II2;
D1←NEW_RECORD(DIMENS_EXPONENT);
II2←D2;
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←-DIMENS_EXPONENT:temp[II2];];
BASIC_DIMENSIONS;
β
ELSE D1←NULL_RECORD;
RETURN(D1);
β;
RECORD_POINTER(DIMENS_EXPONENT)
PROCEDURE MULTIPLY_DIMENSIONS(RECORD_POINTER(DIMENS_EXPONENT)D2,D3);
α
RECORD_POINTER(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←D3;
β
ELSE
α
RECORD_POINTER(DIMENS_EXPONENT) II2,II3;
D1←NEW_RECORD(DIMENS_EXPONENT);
II2←D2;II3←D3;
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[II2]+
DIMENS_EXPONENT:temp[II3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
RECORD_POINTER(DIMENS_EXPONENT)
PROCEDURE DIVIDE_DIMENSIONS(RECORD_POINTER(DIMENS_EXPONENT)D2,D3);
α
RECORD_POINTER(DIMENS_EXPONENT) D1;
IF D2=NULL_RECORD OR D3=NULL_RECORD THEN
α
IF D2≠NULL_RECORD THEN D1←D2
ELSE IF D3≠NULL_RECORD THEN D1←INVERSE_DIMENSIONS(D3);
β
ELSE
α
RECORD_POINTER(DIMENS_EXPONENT)II2,II3;
D1←NEW_RECORD(DIMENS_EXPONENT);
II2←D2;II3←D3;
redefine xx(temp)=[DIMENS_EXPONENT:temp[D1]←DIMENS_EXPONENT:temp[II2]-
DIMENS_EXPONENT:temp[II3];];
BASIC_DIMENSIONS;
β;
RETURN(D1);
β;
! check_entry,insert_entry into tables;
RECORD_POINTER (ANY_CLASS) PROCEDURE CHECK_ENTRY (STRING S; INTEGER TABLE_TYPE);
α
RECORD_POINTER(ANY_CLASS)S1;
INTEGER INDEX;
INDEX←HASH(S,HASHER);
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α RECORD_POINTER(ID_LIST) R1;
R1←SYMBOL_TABLE[INDEX];
WHILE R1≠NULL
DO IF EQU(S,ID_LIST:NAME[R1]) THEN DONE ELSE R1←ID_LIST:NEXT[R1];
S1←R1;
β;
[MACRO_TYPE_TABLE] α RECORD_POINTER (MACRO_LIST) R1;
R1←MACRO_TABLE[INDEX];
WHILE R1≠NULL DO IF EQU(S,MACRO_LIST:ID[R1]) THEN DONE ELSE
R1←MACRO_LIST:NEXT[R1];
S1←R1;
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α RECORD_POINTER(MACRO_STACK) R1;
RECORD_POINTER(MACRO_LIST)R2;
R2←NULL_RECORD;
R1←MACRO_STACK_TOP;
WHILE R1≠NULL
DO IF EQU(S,MACRO_LIST:ID[MACRO_STACK:LIST_PTR[R1]])
THEN α
R2←MACRO_STACK:LIST_PTR[R1];
DONE
β
ELSE R1←MACRO_STACK:STACK_LINK[R1];
S1←R2;
β;
[DIMENSION_TYPE_TABLE]
α RECORD_POINTER(DIMENS_EXPONENT) R1;
R1←DIMENS_TABLE[INDEX];
WHILE R1≠NULL
DO IF EQU(S,DIMENS_EXPONENT:NAME[R1]) THEN DONE ELSE
R1←DIMENS_EXPONENT:NEXT[R1];
S1←R1;
β
β;
RETURN(S1);
β;
RECORD_POINTER (ANY_CLASS) PROCEDURE INSERT_ENTRY (STRING S; INTEGER TABLE_TYPE;
RECORD_POINTER(ANY_CLASS) RR1(NULL_RECORD));
α
RECORD_POINTER(ANY_CLASS) S1; INTEGER INDEX;
INDEX←HASH(S,HASHER);
CASE TABLE_TYPE OF
α
[ID_TYPE_TABLE] α RECORD_POINTER(ID_LIST) R1;
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(ID_LIST) ELSE R1←RR1;
ID_LIST:NEXT[R1]←SYMBOL_TABLE[INDEX];
ID_LIST:NAME[R1]←S;
SYMBOL_TABLE[INDEX]←R1;
IF RR1 = NULL_RECORD THEN
α ID_LIST:LINK[R1]←TOP_ID;
TOP_ID←R1;DEC_NUM←DEC_NUM+1; β;
S1←R1;
β;
[MACRO_TYPE_TABLE] α RECORD_POINTER(MACRO_LIST) R1;
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(MACRO_LIST) ELSE R1←RR1;
MACRO_LIST:NEXT[R1]←MACRO_TABLE[INDEX];
MACRO_LIST:ID[R1]←S;
MACRO_TABLE[INDEX]←R1;
S1←R1;
β;
[MACRO_IN_MACRO_TYPE_TABLE]
α RECORD_POINTER (MACRO_STACK) R1;
record_pointer (macro_list)r2;
IF RR1=NULL_RECORD THEN R2←NEW_RECORD(MACRO_list) ELSE R2←RR1;
r1←new_record(macro_stack);
MACRO_STACK:STACK_LINK[R1]←macro_stack_top;
macro_stack:list_ptr[r1]←r2;
MACRO_STACK_TOP←R1;
macro_list:id[r2]←s;
S1←R2;
β;
[DIMENSION_TYPE_TABLE]
α RECORD_POINTER (DIMENS_EXPONENT) R1;
IF RR1=NULL_RECORD THEN R1←NEW_RECORD(DIMENS_EXPONENT) ELSE R1←RR1;
DIMENS_EXPONENT:NAME[R1]←S;
DIMENS_EXPONENT:NEXT[R1]←DIMENS_TABLE[INDEX];
DIMENS_TABLE[INDEX]←R1;
S1←R1;
β
β;
RETURN(S1);
β;
! reduce, vmake_R;
PROCEDURE REDUCE;
α INTEGER CUR_OP_NUM; LABEL RAISE;
PROCEDURE FAIL_UP(INTEGER I; STRING S);
α RECORD_POINTER(EXPR)E;RECORD_POINTER(EXPR_LIST)EL;
ERROR(I,S&crlf&"I will reduce it to GARB_ID as default.");
E←NEW_RECORD(EXPR);
EL←NEW_RECORD(EXPR_LIST);
EXPR:TYPE[E]←scalar_VALUE;
EXPR:OP[E]←null;
EXPR:ID[E]←"GARB_ID";
EXPR_LIST:NEXT[EL]←EXPRS;
EXPR_LIST:EXP[EL]←E;
EXPRS←EL;
GO TO RAISE;
β;
procedure vmake_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! VMAKE FOUND;
RECORD_POINTER (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL 3 DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF scalar_VALUE≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"VMAKE";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPRS←TEMP;
β;
! tmake_r, fmake_r;
procedure ft_make(Boolean tr);
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP;
RECORD_POINTER (EXPR) E1,E2,E3;
STRING MAKE, FT;
IF TR THEN α MAKE←"TMAKE"; FT←" trans"; β
ELSE α MAKE←"FMAKE"; FT←" frame"; β;
IF EXPRS=NULL_RECORD OR EXPR_LIST:NEXT[EXPRS]=NULL_RECORD THEN
FAIL_UP(108,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠vector_VALUE THEN
α E3←E1; E1←E2; E2←E3; β;
IF EXPR:TYPE[E1]≠vector_VALUE OR EXPR:TYPE[E2]≠rot_VALUE
THEN ERROR(109,"Type mismatch.");
CHECK_DIMENSIONS("vector part of"&FT,EXPR:DIMEN[E1],DISTANCE_DIMENS);
CHECK_DIMENSIONS("rot part of"&FT,EXPR:DIMEN[E2],ANGLE_DIMENS);
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←E1;
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[CUR_PARTS]←E2;
E3←NEW_RECORD(EXPR);
EXPR:PARTS[E3]←CUR_PARTS;
EXPR:OP[E3]←MAKE;
EXPR:TYPE[E3]←trans_VALUE;
IF ¬TR THEN EXPR:DIMEN[E3]←distance_dimens; ! TO ENSURE THAT TRANS*TRANS WILL
NOT GIVE DIMENSIONS OF DISTANCE*DISTANCE;
EXPR_LIST:EXP[EXPRS]←E3;
β;
procedure tmake_R;
ft_make(TRUE); ! TMAKE FOUND;
procedure fmake_R;
ft_make(FALSE); ! FMAKE FOUND;
! vvtrans_R, sneg_R;
procedure vvtrans_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! VVVTRANS FOUND;
RECORD_POINTER (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL 3 DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF vector_VALUE≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"VVVTRANS";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPRS←TEMP;
β;
procedure sneg_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "SNEG" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠scalar_VALUE THEN ERROR(112,"You can only take the opposite of scalars."
&crlf&"Continue will pass the bug through.");
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:OP[CUR_EXPR]←"SNEG";
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[CUR_PARTS]←E1;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
EXPR:DIMEN[CUR_EXPR]←EXPR:DIMEN[E1];
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! rinv_R, sabs_R;
procedure rinv_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "RINV" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
CUR_EXPR←NEW_RECORD(EXPR);
IF EXPR:TYPE[E1]=rot_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"RINV";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β
ELSE IF EXPR:TYPE[E1]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"TINVRT";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
ELSE ERROR(112,"You can only take the inverse of rotations and transforms."
&crlf&"Continue will pass bug through.");
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[CUR_PARTS]←E1;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:DIMEN[CUR_EXPR]←INVERSE_DIMENSIONS(EXPR:DIMEN[E1]);
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure sabs_R;
α ! "SABS" SHOULD BE HANDLED IN P_EXP; ERROR(-1,"PARSER ERROR"); β;
! plus_R,minus_R;
procedure plus_minus_R(boolean plus);
α
STRING S,V,TV, COMMM;
RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF PLUS THEN α S←"SADD"; V←"VADD"; TV←"TVADD"; COMMM←"addition "; β
ELSE α S←"SSUB"; V←"VSUB"; TV←"TVSUB"; COMMM←"subtraction "; β;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≥EXPR:TYPE[E2] THEN α E3←E1; E1←E2; E2←E3; β;
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:DIMEN[CUR_EXPR]←CHECK_DIMENSIONS(COMMM&"expression",EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
IF EXPR:TYPE[E1]=scalar_VALUE THEN
α
IF EXPR:TYPE[E2]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←S;
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β
ELSE IF EXPR:TYPE[E1]=vector_VALUE THEN
α
IF EXPR:TYPE[E2]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←V;
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
ELSE IF EXPR:TYPE[E2]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←TV;
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure plus_R;
plus_minus_R(TRUE); ! "+" FOUND;
procedure minus_R;
plus_minus_R(FALSE); ! "-" FOUND;
! times_R;
procedure times_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "*" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E2]=vector_VALUE THEN α E3←E1; E1←E2; E2←E3; β;
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:DIMEN[CUR_EXPR]←
MULTIPLY_DIMENSIONS(EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
IF EXPR:TYPE[E1]≤trans_VALUE
THEN CASE EXPR:TYPE[E1] OF
α "E1"
[scalar_VALUE] α
IF EXPR:TYPE[E2]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"SMUL";
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β;
[vector_VALUE] IF EXPR:TYPE[E2]≤trans_VALUE
THEN CASE EXPR:TYPE[E2] OF
α "E2"
[scalar_VALUE] α
EXPR:OP[CUR_EXPR]←"SVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β;
[vector_VALUE] ERROR(109,"Type mismatch.");
[rot_VALUE] α
EXPR:OP[CUR_EXPR]←"RVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β;
[frame_VALUE] ERROR(109,"Type mismatch.");
[plane_VALUE] ERROR(109,"Type mismatch.");
[trans_VALUE] α
EXPR:OP[CUR_EXPR]←"TVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
β "E2"
ELSE ERROR(109,"Type mismatch.");
[rot_VALUE] α
IF EXPR:TYPE[E2]≠rot_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"RRMUL";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β;
[frame_VALUE] ERROR(120,"Type mismatch.");
[plane_VALUE] ERROR(120,"Type mismatch.");
[trans_VALUE] α
IF EXPR:TYPE[E2]≠trans_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"TTMUL";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
β "E1"
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! rot_R, wrt_R;
procedure rot_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "ROT" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E2]≠vector_VALUE THEN ERROR(109,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"AXW_ROTN";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure wrt_R;
α RECORD_POINTER (OP_LIST) OP_SAVE;
COMMENT
vector WRT frame
GETS TRANSLATED TO
(TVMUL (ORIENT frame) vector)
SO THIS PROCEDURE MERELY CHAANGES THE TOP OF THE OP_LIST
DOING NO REAL REDUCTION. THE REDUCTION IS THEN DONE ON THE
FOLLOWING TWO PASSES. (NOTE: THIS MEANS THAT THE PRECEDENCE
OF WRT IS DIFFERENT DEPENDING ON WHICH SIDE YOU SEE IT FROM.
;
OP_LIST:OP[OPS]←times_X;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS]← SPECIAL_INFO;
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[orient_X];
OP_LIST:FUNC[OPS]←FALSE;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[orient_X];
OP_LIST:OP[OPS]←orient_X;
COMMENT NOTE THAT THE END OF REDUCE (where the execution goes next)
WILL THROW AWAY THE TOP OP ON OP_LIST, SO WE'RE GOING TO
PUT ON A DUMMY OPERATOR;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
β;
! →_R;
procedure →_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "→" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠EXPR:TYPE[E2] THEN ERROR(111,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:DIMEN[CUR_EXPR]←
MULTIPLY_DIMENSIONS(EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
IF EXPR:TYPE[E1]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"VTOV";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β
ELSE IF EXPR:TYPE[E1]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"FTOF";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! reduce execution starts here;
CUR_OP_NUM←OP_LIST:OP[OPS];
IF ¬(1 ≤ CUR_OP_NUM ≤ op_count)
THEN FAIL_UP(1030,"Trying to parse expression and found garbage.");
IF OP_BOOL[CUR_OP_NUM] THEN
CASE CUR_OP_NUM - first_true_op OF
α
redefine xx(str1, i1, boole, i2, i3, i4, str2)=[
ifc boole
thenc
redefine xx_temp=ifc "str2"=null thenc [str1] elsec [str2] endc & "_R";
xx_temp;
endc ];
operator_definitions;
β
ELSE α RECORD_POINTER(EXPR_LIST) CUR_PARTS,TEMP;
RECORD_POINTER (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL OP_NUM[CUR_OP_NUM] DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF TYPE_OF_ARGS[CUR_OP_NUM]≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
AND TYPE_OF_ARGS[CUR_OP_NUM]≥0
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
CASE DIMEN_CHANGES[CUR_OP_NUM] OF
α
[ignore_dimen] ;
[same_dimen] α
EXPR:DIMEN[CUR_EXPR]←EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]];
β;
[inverse_dimen] α
EXPR:DIMEN[CUR_EXPR]←
INVERSE_DIMENSIONS(EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]]);
β;
[check_dimen] α RECORD_POINTER(EXPR) E1,E2;
E1←EXPR_LIST:EXP[CUR_PARTS];
E2←EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]];
EXPR:DIMEN[CUR_EXPR]←CHECK_DIMENSIONS("expression",EXPR:DIMEN[E1],EXPR:DIMEN[E2]);
β;
[multiply_dimen] EXPR:DIMEN[CUR_EXPR]←
MULTIPLY_DIMENSIONS(
EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]]);
[divide_dimen] EXPR:DIMEN[CUR_EXPR]←
DIVIDE_DIMENSIONS(
EXPR:DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]])
β;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←OP_ARRAY[CUR_OP_NUM];
IF RESULT_TYPE[CUR_OP_NUM]≥0 THEN
EXPR:TYPE[CUR_EXPR]←RESULT_TYPE[CUR_OP_NUM] ELSE
EXPR:TYPE[CUR_EXPR]←EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]];
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPRS←TEMP;
β;
RAISE: OPS←OP_LIST:NEXT[OPS];
β;
! printexpr;
RECURSIVE PROCEDURE PRINTEXPR(RECORD_POINTER (EXPR) E);
IF EQU(EXPR:OP[E],null) THEN OUTEXPR←OUTEXPR&EXPR:ID[E]
ELSE α RECORD_POINTER (EXPR_LIST) SUBS;
OUTEXPR←OUTEXPR&"("&EXPR:OP[E];
SUBS←EXPR:PARTS[E];
WHILE SUBS≠NULL DO
α
OUTEXPR←OUTEXPR&" ";
PRINTEXPR(EXPR_LIST:EXP[SUBS]);
SUBS←EXPR_LIST:NEXT[SUBS];
β;
OUTEXPR←OUTEXPR&")";
β;
! p_exp2;
! PARSE EXPRESSIONS AND SAVE PARSED STRUCTURE INTERNALLY FOR LATER PRINTING;
PROCEDURE P_EXP2;
α RECORD_POINTER (ID_LIST) POINT; LABEL FLUSH;
PROCEDURE F_EXP(INTEGER IP; STRING SP);
α RECORD_POINTER(EXPR)E;
ERROR(IP,SP&crlf&"Continue will attempt to flush expression.");
WHILE ( TYPE_OF_TOKEN=id_token
OR (EQU(TOKEN,"(") AND ¬OP_EXPECTED)
OR TYPE_OF_TOKEN=numeric_token
OR (TYPE_OF_TOKEN=special_token
AND ((operator_beg ≤ TYPE_OF_RES_WORD ≤ operator_end)
OR TYPE_OF_RES_WORD=declare_RES)))
DO GET_TOKEN;
OPS←NULL_RECORD;
if exprs≠null_record then
α
E←NEW_RECORD(EXPR);
EXPR:TYPE[E]←scalar_VALUE;
EXPR:ID[E]←"GARB_ID";
EXPR_LIST:NEXT[EXPRS]←NULL_RECORD;
EXPR_LIST:EXP[EXPRS]←E;
β;
GO TO FLUSH;
β;
! parse_special;
procedure parse_special;
α "parse_special" integer j;
define expected_ops=[
xx([(], -1, -1, false, false)
xx([|], sabs_X, -1, true, false)
xx([-], sneg_X, vector_RES, false, false)
xx([/], rinv_X, vector_RES, false, false)
xx(NOT, not_X, not_RES, false, false)
xx([¬], not_X, not_RES, false, false)
xx(VVTRANS, vvtrans_X, vector_RES, false, true)
xx(ROT, rot_X, vector_RES, true, true)
xx(VVROT, vvrot_X, vector_RES, false, true)
xx(VDOT, vdot_X, vector_RES, false, true)
xx(ANGLE, angle_X, vector_RES, false, true)
];
define
op_case=0;
redefine xx(token, op_num, prior, arg_dep, func)=[
redefine op_case=op_case+1;];
expected_ops;
redefine xx(token, op_num, prior, arg_dep, func)=["token",];
preload_array(
expected_name, expected_ops, [own string], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[op_num,];
preload_array(
expected_X, expected_ops, [own integer], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[prior,];
preload_array(
expected_prior, expected_ops, [own integer], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[arg_dep,];
preload_array(
expected_arg, expected_ops, [own boolean], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[func,];
preload_array(
expected_func, expected_ops, [own boolean], 0, op_case);
OPSAVE←OPS; OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS] ← SPECIAL_INFO;
for j←0 step 1 until op_case-1 do if equ(token,expected_name[j]) then done;
if j ≤ op_case-1
then
α integer k;
OP_LIST:PRIORITY[OPS] ← expected_prior[j];
OP_LIST:OP[OPS] ← k ← expected_X[j];
OP_LIST:NUM_OF_ARGS[OPS] ← if k<0 then 1 else op_num[k];
op_list:count[ops] ← 0;
OP_LIST:ARG_DEP[OPS] ← expected_arg[j];
op_list:func[ops] ← expected_func[j];
β
ELSE IF EQU(TOKEN,"⊗")
THEN
α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←trans_VALUE;
EXPR:OP[EXP1]←null;
IF EQU(CURRENT_FRAME,null) THEN
ERROR(1111,"⊗ used outside of MOVE, AFFIX, or UNAFFIX statement is illegal.");
EXPR:ID[EXP1]←CURRENT_FRAME;
EXPR:DIMEN[EXP1]←distance_dimens;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OPS←OP_LIST:NEXT[OPS];
OP_EXPECTED←TRUE;
β
ELSE IF TYPE_OF_RES_WORD=declare_RES
THEN
α "declare_RES"
case special_info of
α "special_info"
[vector_VALUE] α ! VMAKE FOUND;
OP_LIST:OP[OPS] ← vmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[vmake_X];
β;
[frame_VALUE] α ! FMAKE FOUND;
OP_LIST:OP[OPS] ← fmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[fmake_X];
β;
[trans_VALUE] α ! TMAKE FOUND;
OP_LIST:OP[OPS] ← tmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[tmake_X];
β;
[0] F_EXP(103,"Illegal operator.");
[scalar_VALUE] F_EXP(103,"Illegal operator.");
[rot_VALUE] F_EXP(103,"Illegal operator.");
[plane_VALUE] F_EXP(103,"Illegal operator.")
β "special_info";
OP_LIST:COUNT[OPS]←0;
OP_LIST:ARG_DEP[OPS]←FALSE;
OP_LIST:FUNC[OPS]←TRUE;
β "declare_RES"
ELSE if special_info
then
α
OP_LIST:OP[OPS]←SPECIAL_INFO;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[SPECIAL_INFO];
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[SPECIAL_INFO];
β
else f_exp(200, "Doesn't make sense.");
β "parse_special";
! p_exp2 execution begins here, p_exp;
OP_EXPECTED←FALSE; EXPRS←ops←EXP1←EXP2←EXP3←NULL_RECORD; OUTEXPR←null;
GET_TOKEN;
WHILE ( TYPE_OF_TOKEN=id_token
OR (EQU(TOKEN,"(") AND ¬OP_EXPECTED)
OR TYPE_OF_TOKEN=numeric_token
OR (TYPE_OF_TOKEN=special_token
AND ((operator_beg ≤ TYPE_OF_RES_WORD ≤ operator_end)
OR TYPE_OF_RES_WORD=declare_RES)))
DO
α "while"
IF OP_EXPECTED THEN
α "op_expected"
IF EQU(TOKEN,"ROT") THEN
α
TYPE_OF_TOKEN←special_token;
TYPE_OF_RES_WORD←trans_RES;
SPECIAL_INFO←rot_X;
β;
IF TYPE_OF_TOKEN>special_token OR EQU(TOKEN,"(")
THEN F_EXP(101,"Operation needed here.");
α "termin_check" integer match, j; string str;
match ← -1; j←0;
for str ← ")", ",", "|" do
if equ(str, token)
then α match ← j; done β
else j ← j+1;
if match ≥ 0
then case match of
α "match"
! ")"; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠-1 DO REDUCE;
IF OPS=NULL_RECORD THEN done "while";
OPS←OP_LIST:NEXT[OPS];
IF OPS≠NULL_RECORD AND OP_LIST:FUNC[OPS]=TRUE THEN REDUCE;
β;
! ","; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠-1 DO REDUCE;
IF OPS=NULL THEN done "while";
OP_EXPECTED←FALSE;
β;
! "|"; α integer e;
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠17 DO REDUCE;
IF OPS=NULL_RECORD
THEN F_EXP(105,"Mismatched vertical paren.");
OPS←OP_LIST:NEXT[OPS];
EXP1←NEW_RECORD(EXPR);
EXPR:PARTS[EXP1]←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[EXPR:PARTS[EXP1]]←EXPR_LIST:EXP[EXPRS];
EXPR:DIMEN[EXP1]
← EXPR:DIMEN[EXPR_LIST:EXP[EXPRS]];
EXPR:TYPE[EXP1]←scalar_VALUE;
IF (e ← EXPR:TYPE[EXPR_LIST:EXP[EXPRS]])=scalar_VALUE
THEN EXPR:OP[EXP1]←"SABS";
IF E=vector_VALUE THEN EXPR:OP[EXP1]←"VMAGN";
IF E=rot_VALUE THEN EXPR:OP[EXP1]←"RMAGN";
if e≠scalar_value or e≠vector_value or e≠rot_value
then ERROR(106,"Type mismatch for |.|.");
EXPR_LIST:EXP[EXPRS]←EXP1;
β
β "match"
ELSE
α
IF TYPE_OF_RES_WORD=0
THEN F_EXP(1000,"Sorry, OP not implemented yet.");
WHILE OPS≠NULL_RECORD AND OP_LIST:PRIORITY[OPS]≥TYPE_OF_RES_WORD
DO REDUCE;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS]←TYPE_OF_RES_WORD;
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[SPECIAL_INFO];
OP_LIST:FUNC[OPS]←FALSE;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[SPECIAL_INFO];
OP_LIST:OP[OPS]←SPECIAL_INFO;
OP_EXPECTED←FALSE;
β
β "termin_check"
β "op_expected"
ELSE case TYPE_OF_TOKEN of
α "type_of_token"
[id_token] α RECORD_POINTER (ID_LIST) PPPP;
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))=NULL_RECORD THEN
α
ERROR(13,"Undefined ID "&TOKEN& " probably a frame");
POINT ← SYMBOL_TABLE[HASH("GARB_ID",hasher)];
TOKEN←"GARB_ID";
β;
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←ID_LIST:TYPE[POINT];
EXPR:DIMEN[EXP1]←ID_LIST:DIMEN[POINT];
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←TOKEN;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OP_EXPECTED←TRUE;
β;
[numeric_token] α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←scalar_VALUE;
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←TOKEN;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OP_EXPECTED←TRUE;
β;
[special_token] parse_special;
[string_token] F_EXP(100,"Illegal expression.")
β "type_of_token";
GET_TOKEN;
β "while";
FLUSH:
REJECT←TRUE;
WHILE OPS≠NULL_RECORD DO REDUCE;
IF EXPRS=NULL
THEN
α
ERROR(107,"Empty expression, continue will insert GARBID");
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[EXPRS]←NEW_RECORD(EXPR);
EXPR:ID[EXPR_LIST:EXP[EXPRS]]←"GARB_ID";
β
ELSE IF EXPR_LIST:NEXT[EXPRS]≠NULL THEN ERROR(107,"Can't reduce expression.");
EXP_DIMENS←EXPR:DIMEN[EXPR_LIST:EXP[EXPRS]];
PRINTEXPR(EXPR_LIST:EXP[EXPRS]);
EXP_TYPE←EXPR:TYPE[EXPR_LIST:EXP[EXPRS]];
β;
! PARSE EXPRESSIONS AND IMMEDIATELY PRINT EXPRESSION IN ALCODE FORM;
PROCEDURE P_EXP;
α
P_EXP2;
PRINT(OUTEXPR);
β;
! P_condition;
! CONDITION FINDER - NOT YET INCLUDED;
BOOLEAN PROCEDURE P_CONDITION(INTEGER PP;STRING PRELUDE);
α STRING COND,OP; LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
GO TO FLUSH;
β;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠0 THEN
F_STATE(44,"Bogus condition monitor.");
IF SPECIAL_INFO=nil_CM
THEN COND←TOKEN
ELSE
α INTEGER FORCE_TYPE;
! YOU MIGHT WANT TO INCORPORATE ALL OF THIS INTO P_EXP2;
FORCE_TYPE←SPECIAL_INFO;
COND←"(FORCE ";
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1201,"Need left paren here. Continue will insert it.");
IF FORCE_TYPE=torque_CM
THEN COND←COND&"NILVECT "
ELSE
α
P_EXP2;
IF EXP_TYPE≠vector_VALUE THEN F_STATE(1202,"Need vector here.");
COND←COND&OUTEXPR&" ";
β;
IF FORCE_TYPE=force_or_torque_CM THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN ERROR(1203,"Need comma here. Continue will insert it.");
β;
IF FORCE_TYPE=force_CM
THEN COND←COND&"NILVECT"
ELSE
α
P_EXP2;
IF EXP_TYPE≠vector_VALUE THEN F_STATE(1202,"Need vector here.");
COND←COND&OUTEXPR;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,")") THEN
ERROR(1201,"Need right paren here. Continue will insert it.");
COND←COND&")";
β;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠order_RES
THEN F_STATE(44,"Bogus condition monitor.");
OP←OP_ARRAY[SPECIAL_INFO];
PRINT(PRELUDE&" ("&OP&" "&COND);
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN ERROR(49,"Need scalar quantity here.");
PRINT(")");
SPACING←SPACING-1;
RETURN(FALSE);
FLUSH: RETURN(TRUE);
β;
! P_clauses, T_gen;
PROCEDURE P_CLAUSES;
α BOOLEAN T; LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
SPACING←SPACING-2;
PRINT("))");
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
GO TO FLUSH;
β;
T←TRUE;
GET_TOKEN;
WHILE T DO
IF TYPE_OF_TOKEN≠special_token THEN
α RECORD_POINTER (ID_LIST) POINT; STRING LABL;
! LABELED CONDITION MONITOR FOUND;
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))=NULL_RECORD
OR ID_LIST:TYPE[POINT]≠cm_label_VALUE
THEN
ERROR(51,"Illegal or undefined ID. Can only handle Condition Monitor ID here.");
LABL←TOKEN&" ";
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN
ERROR_REJECT(53,"Need semicolon here. Continue will insert it.");
GET_TOKEN;
IF ¬EQU(TOKEN,"ON") THEN
ERROR_REJECT(52,"Need ON here for a condition monitor.");
P_CONDITION(2,"("&LABL&"ON");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β
ELSE IF TYPE_OF_RES_WORD=on_RES THEN
α
! UNLABELED CONDITION MONITOR FOUND;
P_CONDITION(2,"("&"ON");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β
ELSE IF EQU(TOKEN,"(") THEN
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
GET_TOKEN;
β
ELSE IF ¬(move_beg ≤ TYPE_OF_RES_WORD ≤ move_end) THEN
α
! END OF MOVE STATEMENT FOUND;
REJECT←TRUE;
T←FALSE;
β
ELSE CASE TYPE_OF_RES_WORD - move_beg OF
α
[via_X] α
! VIA CLAUSE FOUND;
PRINT("(VIA ");
SPACING←SPACING+1;
P_EXP;
GET_TOKEN;
IF EQU(TOKEN,",") THEN
α;
SPACING←SPACING-1;
PRINT(")");
WHILE EQU(TOKEN,",") DO
α
PRINT("(VIA ");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β;
β
ELSE α BOOLEAN V_FOUND,D_FOUND,CONTIN;
CONTIN←TRUE;
IF EQU(TOKEN,"WITH") THEN
WHILE ¬(V_FOUND ∧ D_FOUND) ∧ CONTIN DO
α
GET_TOKEN;
IF V_FOUND ∧ EQU(TOKEN,"VELOCITY") THEN
F_STATE(3011,"Multiple VELOCITY specification found in WITH clause.")
ELSE IF EQU(TOKEN,"VELOCITY") THEN
α
PRINT("(VELOCITY ");
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3014,"Need = here.");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT(")");
IF EXP_TYPE≠vector_VALUE THEN
α
SPACING←SPACING-1;
PRINT(")");
F_STATE(3012,"Need a vector expression here.");
β;
V_FOUND←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE IF D_FOUND ∧ EQU(TOKEN,"DURATION") THEN
F_STATE(3013,"Multiple DURATION specification found in WITH clause.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("(DURATION " & TOKEN & " ");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT(")");
IF EXP_TYPE≠scalar_VALUE THEN
α
SPACING←SPACING-1;
PRINT(")");
F_STATE(3012,"Need a scalar expression here.");
β;
D_FOUND←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE CONTIN←FALSE;
β;
IF EQU(TOKEN,"THEN") THEN
α;
PRINT("(THEN");
SPACING←SPACING+1;
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β;
SPACING←SPACING-1;
PRINT(")");
β;
β;
[with_X] α;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token THEN F_STATE(3017,"Illegal WITH clause.")
ELSE IF TYPE_OF_RES_WORD=arrival_RES THEN
α
PRINT("(" & TOKEN);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022,"Need = here.");
GET_TOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN PRINT("NILDEPROACH")
ELSE IF EQU(TOKEN,"DEPROACH") THEN
α
PRINT("(DEPR");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(3019,"Need left paren here.");
P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN F_STATE(3020,"Need frame exp here.");
GET_TOKEN;
IF ¬EQU(TOKEN,")") THEN ERROR_REJECT(3021,"Need right paren here.");
SPACING←SPACING-1;
PRINT(")");
β
ELSE α
REJECT←TRUE;
P_EXP;
IF EXP_TYPE≠scalar_VALUE ∧ EXP_TYPE≠vector_VALUE ∧ EXP_TYPE≠trans_VALUE THEN
ERROR(3018,"Type mismatch for DEPROACH.");
β;
SPACING←SPACING-1;
PRINT(")");
β
ELSE IF EQU(TOKEN,"WOBBLE") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022, "Need = here.");
PRINT("(WOBBLE ");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN F_STATE(3012,"Need a scalar expression here.");
SPACING←SPACING - 1;
PRINT(")");
β
ELSE IF EQU(TOKEN,"FORCE") THEN F_STATE(3015,"SORRY, CAN'T HANDLE FORCE " &
"CLAUSES YET.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α;
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("(DURATION " & TOKEN & " ");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT(")");
IF EXP_TYPE≠scalar_VALUE THEN
F_STATE(3012,"Need a scalar expression here.");
β
ELSE F_STATE(3016,"Illegal WITH clause.");
GET_TOKEN;
β
β;
FLUSH:
β;
STRING PROCEDURE T_GEN;
α
T_COUNT←T_COUNT+1;
RETURN("_T"&CVS(T_COUNT));
β;
! P_statement, begin_P;
RECURSIVE PROCEDURE P_STATEMENT;
α "P_STATEMENT"
LABEL FLUSH,TRY_AGAIN; STRING LABL; INTEGER LABEL_TYPE;
RECORD_POINTER(DIMENS_EXPONENT) DIM_PTR;
PROCEDURE F_STATE(VALUE INTEGER PP,IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
GO TO FLUSH;
β;
procedure begin_P;
α INTEGER SAVE_DEC_NUM;
STRING B1,B2,E1,E2,TT;
TT←"("&LABL;
B1←B2←"BEGIN";
E1←E2←"END";
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
IF EQU(TOKEN,"BEGIN") THEN
α B2←"CO"&B2;E2←"CO"&E2;TT←TT&"BL";β
ELSE α B1←"CO"&B1;E1←"CO"&E1;TT←TT&"CO";β;
PRINT(TT);
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,E1) DO
α
P_STATEMENT;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠end_RES
THEN ERROR_REJECT(4,
"Need semicolon before this token ⊂"&TOKEN&"⊃")
ELSE IF EQU(TOKEN,E2) THEN
α
ERROR(5,"Block ends with " & E2 & cr
& "Continue to view as "& E1);
TOKEN←E1;
β;
β;
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α
SYMBOL_TABLE[HASH(ID_LIST:NAME[TOP_ID],hasher)]
← ID_LIST:NEXT[TOP_ID];
TOP_ID←ID_LIST:LINK[TOP_ID];
β;
DEC_NUM←SAVE_DEC_NUM;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
PRINT(")");
β;
! end_P, open_paren_P;
procedure end_P;
α ! SEMICOLON FOUND - NOOP;
REJECT←TRUE;
β;
procedure open_paren_P;
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
β;
! declare_P;
procedure declare_P;
α
STRING BUILD_OUT; INTEGER TYPE1;
RECORD_POINTER(DIMENS_EXPONENT) DIM;
procedure default_metric;
IF SPECIAL_INFO= frame_VALUE
THEN DIM←DISTANCE_DIMENS ELSE DIM←nil_dimens;
procedure check_metric;
CASE SPECIAL_INFO OF
α
[frame_value] IF DIM≠DISTANCE_DIMENS
THEN α ERROR(3000,"Frame can take only distance dimensions");
DIM←DISTANCE_DIMENS;
β;
[label_value] ;
[trans_VALUE] IF DIM≠NIL_DIMENS
THEN α ERROR(3000,"Trans must be dimensionless");
DIM←NIL_DIMENS;
β
β;
IF (DIM←DIM_PTR)=NULL_RECORD THEN DEFAULT_METRIC;
check_metric;
BUILD_OUT←"("&LABL&DEC_NAME[SPECIAL_INFO];
IF SPECIAL_INFO≠frame_VALUE
THEN TYPE1←SPECIAL_INFO ELSE TYPE1←trans_VALUE;
GET_TOKEN;
WHILE ¬EQU(TOKEN,";") DO
α RECORD_POINTER (ID_LIST) POINT,SCAN_POINT;
IF (SCAN_POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL
THEN IF ID_LIST:BLOCK_LEVEL_OF_DEFN[SCAN_POINT]=BLOCK_LEVEL
THEN ERROR(3001,"⊂"&TOKEN&"⊃ is multiply defined "
&"in this block.");
BUILD_OUT←BUILD_OUT&" "&TOKEN;
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←TYPE1;
ID_LIST:DIMEN[POINT]←DIM;
ID_LIST:BLOCK_LEVEL_OF_DEFN[POINT]←BLOCK_LEVEL;
GET_TOKEN;
IF EQU(TOKEN,";") THEN REJECT←TRUE
ELSE IF ¬EQU(TOKEN,",") THEN
ERROR_REJECT(7,"Missing comma.");
GET_TOKEN;
β;
REJECT←TRUE;
PRINT(BUILD_OUT&")");
β;
! global_P;
procedure global_P;
α INTEGER O_DIM;
PRINT("("&LABL&"GVAR"); SPACING←SPACING+1; GET_TOKEN;
IF TYPE_OF_TOKEN=special_token AND TYPE_OF_RES_WORD=metric_RES
THEN α O_DIM←SPECIAL_INFO; GET_TOKEN; β;
WHILE ¬EQU(TOKEN,";") DO
α STRING BUILD_OUT; INTEGER TYPE1;
RECORD_POINTER(DIMENS_EXPONENT) DIM;
DIM←DIMENS_TABLE[O_DIM];
IF TYPE_OF_RES_WORD≠declare_RES
THEN F_STATE(1,8,"Need variable type here.");
TYPE_OF_RES_WORD←-1; ! reset to get WHILE LOOP started;
BUILD_OUT←"("&DEC_NAME[SPECIAL_INFO]; TYPE1←SPECIAL_INFO;
GET_TOKEN;
IF TYPE_OF_TOKEN=special_token AND TYPE_OF_RES_WORD=metric_RES
THEN α DIM←DIMENS_TABLE[SPECIAL_INFO]; GET_TOKEN; β;
WHILE ¬EQU(TOKEN,";")AND TYPE_OF_RES_WORD≠declare_RES DO
α RECORD_POINTER (ID_LIST) POINT,SCAN_POINT;
IF TYPE_OF_TOKEN≠id_token THEN F_STATE(1,6,"Illegal token"
&" or attempt to declare reserved word.");
IF (SCAN_POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL
THEN IF ID_LIST:BLOCK_LEVEL_OF_DEFN[SCAN_POINT]=BLOCK_LEVEL
THEN ERROR(3001,"⊂"&TOKEN&"⊃ is multiply defined "
&"in this block.");
BUILD_OUT←BUILD_OUT&" "&TOKEN;
POINT←INSERT_ENTRY(TOKEN,ID_TYPE_TABLE);
ID_LIST:TYPE[POINT]←TYPE1;
ID_LIST:DIMEN[POINT]←DIM;
ID_LIST:BLOCK_LEVEL_OF_DEFN[POINT]←BLOCK_LEVEL;
GET_TOKEN;
IF EQU(TOKEN,";")OR TYPE_OF_RES_WORD=declare_RES
THEN REJECT←TRUE
ELSE IF ¬EQU(TOKEN,",")
THEN ERROR_REJECT(7,"Missing comma.");
GET_TOKEN;
β;
PRINT(BUILD_OUT&")");
β;
REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
! if_P, plan_P, while_P;
procedure if_P;
α ! IF STATEMENT FOUND;
IF PLAN_STATEMENT THEN PRINT("("&LABL&"CIF") ELSE PRINT("("&LABL&"IF");
PLAN_STATEMENT←FALSE;
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(1,10,"Conditional for IF must be boolean");
GET_TOKEN;
IF ¬EQU(TOKEN,"THEN") THEN
ERROR_REJECT(9,"Missing THEN. Continue will insert it.");
P_STATEMENT;
GET_TOKEN;
IF EQU(TOKEN,"ELSE") THEN P_STATEMENT ELSE REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
procedure plan_P;
α ! PLAN STATEMENT FOUND;
GET_TOKEN;
REJECT←TRUE;
PLAN_STATEMENT←TRUE;
IF ¬(EQU(TOKEN,"IF") OR EQU(TOKEN,"WRITE") OR EQU(TOKEN,"ERROR")
OR EQU(TOKEN,"FOREACH")) THEN F_STATE(0,11,"Illegal token to "&
"follow PLAN: "&TOKEN);
P_STATEMENT;
PLAN_STATEMENT←FALSE;
β;
procedure while_P;
α ! WHILE STATEMENT FOUND;
PRINT("("&LABL&"WH");
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,11,"Conditional for WHILE must be boolean or sclar.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(12,"Missing DO. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! for_P;
procedure for_P;
α RECORD_POINTER(ID_LIST) POINT; ! FOR STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(1300,"Need scalar ID here.");
! change 13 to something else;
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠scalar_VALUE THEN
α
ERROR(1300,"Need scalar ID here.");
! change 13 to something else;
POINT ← SYMBOL_TABLE[HASH("GARB_ID",hasher)];
β;
PRINT("("&LABL&"FO "&ID_LIST:NAME[POINT]);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"←") THEN
ERROR_REJECT(14,"Need left arrow here for FOR statement.");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN
ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"STEP") THEN
ERROR_REJECT(16,"Need STEP here.");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN
ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"UNTIL") THEN
ERROR_REJECT(17,"Need UNTIL here.");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN
ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(18,"Need DO here.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! move_P;
procedure move_P;
α RECORD_POINTER(ID_LIST) POINT; ! MOVE STATEMENT FOUND;
GET_TOKEN;
IF ¬EQU(TOKEN,"BARM") AND ¬EQU(TOKEN,"YARM") THEN
α
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE)) =NULL_RECORD
THEN POINT←ERROR(13,"Need frame ID here.");
IF ID_LIST:TYPE[POINT]≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
β;
CURRENT_FRAME←TOKEN;
PRINT("("&LABL&"MO "&TOKEN);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN
ERROR_REJECT(19,"Need TO here.");
P_EXP;
IF EXP_TYPE≠trans_VALUE THEN
ERROR_REJECT(20,"Need either a FRAME or TRANSFORM expression here.");
CURRENT_FRAME←null;
P_CLAUSES;
SPACING←SPACING-1;
PRINT(")");
β;
! affix_p,unfix_p;
procedure affix_p;
α STRING SAVE1,SAVE2,TRANS;
RECORD_POINTER(ID_LIST) POINT;
! AFFIX STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN
ERROR_REJECT(19,"Need frame ID here.");
IF (POINT←check_entry(token,id_type_table))=NULL
THEN POINT←ERROR(13,"Need frame ID here.");
IF ID_LIST:TYPE[POINT]≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
CURRENT_FRAME←TOKEN;
SAVE1←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN
ERROR_REJECT(21,"Need TO here. Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
IF (POINT←check_entry(token,id_type_table))=NULL
THEN POINT←ERROR(13,"Need frame ID here.");
IF ID_LIST:TYPE[POINT]≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
SAVE2←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"BY") THEN
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need TRANS ID here.");
IF (POINT←check_entry(token,id_type_table))=NULL
THEN POINT←ERROR(13,"Need frame ID here.");
IF ID_LIST:TYPE[POINT]≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
TRANS←TOKEN;
β ELSE α
TRANS←T_GEN;
PRINT("(TVAR "&TRANS&")");
REJECT←TRUE;
β;
GET_TOKEN;
IF EQU(TOKEN,"AT") THEN
α
PRINT("("&LABL&"AFFIX "&SAVE1&" "&SAVE2&" "&TRANS);
SPACING←SPACING+1;
P_EXP;
GET_TOKEN;
IF EQU(TOKEN,"RIGIDLY")THEN PRINT("RIGIDLY)")
ELSE IF EQU(TOKEN,"NONRIGIDLY")THEN PRINT("NONRIGIDLY)")
ELSE α PRINT("NONRIGIDLY)");REJECT←TRUE; β;
SPACING←SPACING-1;
β ELSE α STRING HOW;
IF EQU(TOKEN,"RIGIDLY") OR EQU(TOKEN,"NONRIGIDLY") THEN
HOW←TOKEN ELSE α HOW←"NONRIGIDLY";REJECT←TRUE;β;
PRINT("("&LABL&"AFFIX "&SAVE1&" "&SAVE2&" "&TRANS&" () "&HOW&")");
β;
CURRENT_FRAME←null;
β;
procedure unfix_P;
α STRING SAVE1;
RECORD_POINTER(ID_LIST) POINT;
! UNAFFIX STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
IF (POINT←check_entry(token,id_type_table))=NULL
THEN POINT←ERROR(13,"Need frame ID here.");
IF ID_LIST:TYPE[POINT]≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
CURRENT_FRAME←TOKEN;
SAVE1←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"FROM") THEN
ERROR_REJECT(20,"Need FROM here.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
IF (POINT←check_entry(token,id_type_table))=NULL
THEN POINT←ERROR(13,"Need frame ID here.");
IF ID_LIST:TYPE[POINT]≠trans_VALUE
THEN ERROR(19,"Need frame ID here.");
PRINT("("&LABL&"UNFIX"&" "&SAVE1&" "&TOKEN&")");
CURRENT_FRAME←null;
β;
! signal_p, wait_p;
procedure signal_P;
α RECORD_POINTER(ID_LIST) POINT;
! SIGNAL STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need event ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠event_VALUE THEN
ERROR(21,"Need event ID here.");
PRINT("("&LABL&"EV "&TOKEN&" +)");
β;
procedure wait_P;
α RECORD_POINTER(ID_LIST) POINT;
! WAIT STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(20,"Need event ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠event_VALUE THEN
ERROR(21,"Need event ID here.");
PRINT("("&LABL&"EV "&TOKEN&" -)");
β;
! when_P;
procedure when_P;
α RECORD_POINTER (ID_LIST) POINT; STRING VAR, ALSO_OP, CHG_LAB;
BOOLEAN TEMP;
! WHEN STATEMENT FOUND;
GET_TOKEN;
IF ¬EQU(TOKEN,"CHANGING") THEN
ERROR_REJECT(30,"Need word CHANGING here for a WHEN CHANGING statement."&
" Continue will insert it.");
GET_TOKEN;
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))=NULL_RECORD
THEN ERROR(31,"Undefined ID");
VAR←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"ALSO") THEN ALSO_OP←"ALSO_DO"
ELSE IF EQU(TOKEN,"DON'T") THEN ALSO_OP←"ALSO_DON'T"
ELSE IF EQU(TOKEN,"ONLY") THEN ALSO_OP←"ALSO_ONLY"
ELSE ERROR(32,"Illegal ALSO_OP");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(33,"Need DO here. Continue will insert it.");
GET_TOKEN;
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))=NULL_RECORD THEN TEMP←TRUE
ELSE IF ID_LIST:TYPE[POINT]=ch_label_VALUE THEN TEMP←FALSE
! ?????; ELSE IF ID_LIST:TYPE[POINT]>world_VALUE THEN
α
ERROR(34,"Can only handle CH_LABEL here. Continue while delete this label.");
TEMP←TRUE;
β
ELSE TEMP←TRUE;
IF TEMP THEN
α
CHG_LAB←T_GEN;
PRINT("(CHGLAB "&CHG_LAB&")");
REJECT←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE α
CHG_LAB←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,":") THEN
α
TEMP←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE α
REJECT←TRUE;
PRINT("("&ALSO_OP&" "&VAR&" "&CHG_LAB&")");
β;
β;
IF TEMP THEN
α
PRINT("("&ALSO_OP&" "&VAR);
SPACING←SPACING+1;
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
β;
! dump_P;
procedure dump_P;
α RECORD_POINTER (ID_LIST) POINT; BOOLEAN T; STRING IDSTRING;
! DUMP STATEMENT FOUND;
IDSTRING←null;
GET_TOKEN;
T←TRUE;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT≠NULL AND ID_LIST:TYPE[POINT]=world_VALUE THEN
PRINT("("&LABL&"DBD "&TOKEN&")")
ELSE WHILE T DO
α
! ?????; IF POINT=NULL OR ID_LIST:TYPE[POINT]>event_VALUE THEN
ERROR(35,"Undefined ID.");
IDSTRING←IDSTRING&" "&TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN T←FALSE
ELSE α
IF ¬EQU(TOKEN,",") THEN
ERROR_REJECT(36,"Need comma or IN here. Continue wil insert a comma.");
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
β;
β;
IF ¬T THEN
α
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN, ID_TYPE_TABLE);
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(37,"Need a world ID here.");
PRINT("("&LABL&"PVL "&IDSTRING&TOKEN&")");
β;
β;
! assert_P;
procedure assert_P;
α RECORD_POINTER (ID_LIST) POINT; STRING IDSTRING,COM;
INTEGER VAR_TYPE;
! ASSERT OR DENY STATEMENT FOUND;
COM←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"FORM") THEN
α
IDSTRING←null;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR_REJECT(37,"Need left paren here. Continue will insert it.");
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IDSTRING←IDSTRING&TOKEN&" ";
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
ERROR_REJECT(38,"Need either comma or right paren here."&
" Continue will insert a comma.");
β;
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN
α
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(39,"Need world ID here.");
PRINT("("&LABL&COM&" (SF "&IDSTRING&") "&TOKEN&")");
β
ELSE α
REJECT←TRUE;
PRINT("("&LABL&COM&" (SF "&IDSTRING&"))");
β;
β
ELSE α STRING VAR;
POINT←CHECK_ENTRY(VAR←TOKEN,ID_TYPE_TABLE);
! ?????; IF POINT=NULL OR ID_LIST:TYPE[POINT]>trans_VALUE THEN
α
ERROR(40,"Need variable ID here.");
POINT←SYMBOL_TABLE[HASH("GARB_ID",hasher)];
β;
VAR_TYPE←ID_LIST:TYPE[POINT];
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR(41,"Sorry, can only handle equality right now.");
PRINT("("&LABL&COM&" (AF "&VAR&" = ");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
IF VAR_TYPE≠EXP_TYPE THEN ERROR(42,"Types don't match on equality test.");
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN
α
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(39,"Need world ID here.");
PRINT(") "&TOKEN&")");
β
ELSE α
REJECT←TRUE;
PRINT("))");
β;
β;
β;
! on_P, reference_P, parseshit_P, open_P;
procedure on_P;
α RECORD_POINTER (ID_LIST) POINT;
! CONDITION MONITER FOUND;
IF ¬EQU(LABL,null) AND LABEL_TYPE≠cm_label_VALUE THEN
α
ERROR(43,"Must have condition monitor label if any label is uesed. Continue will flush label.");
LABL←null;
β;
P_CONDITION(0,"("&LABL&"ON");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
procedure reference_P;
α RECORD_POINTER (ID_LIST) POINT; ! NEW WORLD DEF;
GET_TOKEN;
IF ¬EQU(TOKEN,"POINT") THEN
ERROR_REJECT(46,"Need POINT here for a REFERENCE POINT statement.");
GET_TOKEN;
POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE);
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(47,"Need a world variable here.");
PRINT("("&LABL&"NW "&TOKEN&")");
β;
procedure parseshit_P;
α ! PARSESHIT FOUND;
ifc debug_compile thenc BAIL; elsec usererr(0, 1, "Parseshit"); endc
β;
procedure open_P;
α STRING HAND; ! OPEN/CLOSE FOUND;
RECORD_POINTER (ID_LIST) POINT;
GET_TOKEN;
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND") THEN HAND←TOKEN
ELSE ERROR(48,"Unknown hand.");
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN
ERROR_REJECT(49,"Need TO here.");
PRINT("("&LABL&"MO "&HAND);
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN ERROR(121,"Need scalar quantity here.");
SPACING←SPACING-1;
PRINT(")");
β;
! center_P, stop_P, define_P;
procedure center_P;
α ! CENTER FOUND;
GET_TOKEN;
IF EQU(TOKEN,"YARM") OR EQU(TOKEN,"BARM")
THEN PRINT("("&LABL&"CENTER "&TOKEN&")")
ELSE ERROR(48,"Unknown hand.");
β;
procedure stop_P;
α ! STOP FOUND;
RECORD_POINTER(ID_LIST) R1;
GET_TOKEN;
IF (EQU(TOKEN,"YARM") OR EQU(TOKEN, "BARM"))
THEN PRINT("("&LABL&"STOP "&TOKEN&")")
ELSE IF (R1←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD
THEN IF ID_LIST:TYPE[R1]=TRANS_VALUE
THEN PRINT("("&LABL&"STOP "&TOKEN&")")
ELSE ERROR(49, "Trying to stop a non-frame")
ELSE ERROR(49, "Trying to stop a non-frame");
β;
procedure define_P;
if ¬macro_handler then goto FLUSH;
! require_P;
procedure require_P;
α ! REQUIRE STATEMENT FOUND;
define control_meta_lf = ['612];
GET_TOKEN;
IF ¬(require_beg ≤ TYPE_OF_RES_WORD ≤ require_end)
THEN F_STATE(0,51, "Illegal token after require.")
ELSE
CASE TYPE_OF_RES_WORD - require_beg OF
α
[source_file_X] α RECORD_POINTER (SOURCE_LIST) NEW_SOURCE;
NEW_SOURCE←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CHAN[NEW_SOURCE]←CHANIN;
SOURCE_LIST:NUM[NEW_SOURCE]←0;
SOURCE_LIST:FILE_NAME[NEW_SOURCE]←INFILE;
SOURCE_LIST:NEXT[NEW_SOURCE]←TOP_SOURCE;
TOP_SOURCE←NEW_SOURCE;
GET_TOKEN;
INFILE←TOKEN;
GET_TOKEN;
REJECT←TRUE;
SOURCE_LIST:PN[NEW_SOURCE]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE]←LINENUM;
SOURCE_LIST:CUR_STRING[NEW_SOURCE]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE]←CURLINER;
if ¬equ(infile,"TTY:") then
α
OPEN(CHANIN←GETCHAN,"DSK",0,4,0,COUNT,BRCHAR,EOF);
EOF←1;
WHILE EOF DO
α
LOOKUP(CHANIN,INFILE,eof);
IF eof THEN
ERROR(55,"Lookup failed on required file - "&INFILE);
β;
CURLINE←CURLINER←NULL; pagenum ← linenum ← 0;
if typed_page_num then outstr(crlf);
file_indent(sourcelvl ← sourcelvl+1);
outstr(infile & " 1"); typed_page_num ← true;
β else
α outstr(crlf & crlf & "End input with <control><meta><lf>" & crlf);
curline←curliner←instrl(control_meta_lf);
chanin←1000;
pagenum←linenum←0;
file_indent(sourcelvl←sourcelvl + 1);
typed_page_num←true;
β;
β;
[delimiters_X] α RECORD_POINTER (DELIMITER_LIST) NEW_DEL;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2 THEN F_STATE(0,53,"Need string of length 2.");
push_delimiters(token);
β;
[unstack_delimiters_X] IF NULL=TOP_DELIMITERS
THEN F_STATE(0,54,"Sorry, delimiter stack empty.")
ELSE TOP_DELIMITERS←DELIMITER_LIST:NEXT[TOP_DELIMITERS];
[replace_delimiters_X] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2
THEN F_STATE(0,53,"Need string of length 2.");
delimiter_list:d1[top_delimiters] ← lop(token);
delimiter_list:d2[top_delimiters] ← lop(token);
β;
[message_x] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
OUTSTR(TOKEN);
β;
[error_modes_x] α
INTEGER I,L; STRING S; BOOLEAN T;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
L←length(token);
FOR I←1 STEP 1 UNTIL L DO
α S←TOKEN[I FOR 1];
IF EQU(S,"-") THEN α I←I+1;
S←TOKEN[I FOR 1];
T←FALSE;
β
ELSE T←TRUE;
IF EQU(S,"L")
THEN α COMPILE_LOGGING←T; IF ¬T THEN LOGGING←T; β
ELSE IF EQU(S,"A")
THEN AUTO_PROCEED←TRUE
ELSE IF EQU(S,"F")
THEN STRICT_DIMEN_CHECK←T
ELSE ERROR(0,"Error_mode " & s & " undefined.");
β;
β;
[switches_x] α
INTEGER I,L,I1; STRING S; BOOLEAN NON_EXIST_SWITCH,BAIL_WANTED;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
L←LENGTH(TOKEN);
FOR I←1 STEP 1 UNTIL L DO
α
S←TOKEN[I FOR 1];
NON_EXIST_SWITCH←TRUE;
FOR I1←0 STEP 1 UNTIL SWITCH_MAX DO
IF EQU(S,SWITCH_NAME[I1]) THEN
α SWITCH_SETTING[I1]←TRUE;
IF I1=B_X THEN BAIL_WANTED←TRUE;
NON_EXIST_SWITCH←FALSE;
β;
IF NON_EXIST_SWITCH THEN
ERROR(0,"Switch " & S & " unknown");
β;
IF BAIL_WANTED
THEN α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β;
β;
[comment_delimiters_x] α
STRING CLOSE_BRACE;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2 THEN F_STATE(0,53,"Need string of length 2.");
OPEN_BRACE←TOKEN[1 FOR 1];
CLOSE_BRACE←TOKEN[2 FOR 1];
SETBREAK(close_brace_break, CLOSE_BRACE, NULL, "ISK");
add_to_table1(token);
β;
[bail_X] α
IFC debug_compile
THENC OUTSTR(crlf & "BAIL requested"); BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β
β;
β;
! dimension_P;
procedure dimension_P;
α "dimen_p"
! DIMENSION STATEMENT FOUND;
INTEGER INDEX; STRING DIMEN_NAME;
RECORD_POINTER(DIMENS_EXPONENT) D1,temp;
BOOLEAN TOP; INTEGER COUNT;
RECORD_CLASS DIMEN_REDUCE(STRING OP; RECORD_POINTER (DIMEN_REDUCE) LAST;
RECORD_POINTER (DIMENS_EXPONENT) DIM_PTR);
RECORD_POINTER (DIMEN_REDUCE) CURRENT,CUR2;
string cur_op;
TOP←TRUE; COUNT←0;
CUR_OP←NULL;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN F_STATE(0,61,"Can only use unreserved ID's for dimensions.");
TEMP←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE);
IF TEMP≠NULL THEN F_STATE(0,61,token &" has already been defined.")
ELSE DIMEN_NAME←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(62,"Need = here.");
GET_TOKEN;
CURRENT←NULL_RECORD;
DIM_PTR←NIL_DIMENS;
WHILE TOKEN≠";" DO
α
WHILE EQU(TOKEN,"INV") OR EQU(TOKEN,"(") OR EQU(TOKEN , ")") OR
EQU(TOKEN,"*") OR EQU(TOKEN,"/") DO
α
IF EQU(TOKEN,"INV") THEN
α CUR2←NEW_RECORD(DIMEN_REDUCE);
DIMEN_REDUCE:OP[CUR2]←"INV";
DIMEN_REDUCE:LAST[CUR2]←CURRENT;
DIMEN_REDUCE:DIM_PTR[CUR2]←DIM_PTR;
DIM_PTR←NIL_DIMENS;
CURRENT←CUR2;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(63,"Need ( here");
COUNT←COUNT+1;
GET_TOKEN;
IF EQU(TOKEN,"/") OR EQU(TOKEN,"*") THEN ERROR
(64, "Can`t have "&token&" after (.");
β
ELSE IF EQU(TOKEN,"(") THEN
α CUR2←NEW_RECORD(DIMEN_REDUCE);
DIMEN_REDUCE:OP[CUR2]←CUR_OP;
cur_op←null;
COUNT←COUNT+1;
DIMEN_REDUCE:LAST[CUR2]←CURRENT;
DIMEN_REDUCE:DIM_PTR[CUR2]←DIM_PTR;
DIM_PTR←NIL_DIMENS;
CURRENT←CUR2;
GET_TOKEN;
IF EQU(TOKEN,"/") OR EQU(TOKEN,"*") THEN ERROR
(64, "Can`t have "&token&" after (.");
β
ELSE IF EQU(TOKEN, "*") or equ(token,"/") THEN
α
CUR_OP←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"*") OR EQU(TOKEN,"/") OR EQU(TOKEN,")")
THEN ERROR(64, "Can't have "&token&" after "&cur_op);
β
ELSE IF EQU(TOKEN,")") THEN
α
if count≤0 then F_STATE(0,65, "Right paren without left paren.")else
IF EQU(DIMEN_REDUCE:OP[CURRENT],"*") THEN
DIM_PTR←MULTIPLY_DIMENSIONS(DIM_PTR,
DIMEN_REDUCE:DIM_PTR[CURRENT])
ELSE IF EQU(DIMEN_REDUCE:OP[CURRENT],"/") THEN
DIM_PTR←DIVIDE_DIMENSIONS(
DIMEN_REDUCE:DIM_PTR[CURRENT],DIM_PTR)
ELSE IF EQU(DIMEN_REDUCE:OP[CURRENT],"INV") THEN
DIM_PTR←INVERSE_DIMENSIONS(DIM_PTR)
ELSE IF DIMEN_REDUCE:OP[CURRENT]≠NULL THEN
ERROR(66, "Can't do this");
CURRENT←DIMEN_REDUCE:LAST[CURRENT];
COUNT←COUNT-1;
IF CURRENT≠NULL_RECORD THEN cur_op←dimen_reduce:op[current]
ELSE CUR_OP←NULL;
GET_TOKEN;
IF EQU(TOKEN,"(") THEN ERROR(64,"Can't have ( after )");
β;
β;
IF TOKEN≠";" THEN
α
D1←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE);
IF D1=NULL_RECORD THEN ERROR(0000, TOKEN & "not declared.")
ELSE IF EQU(CUR_OP,"*") THEN
DIM_PTR←MULTIPLY_DIMENSIONS(DIM_PTR,D1)
ELSE IF EQU(CUR_OP,"/") THEN
DIM_PTR←DIVIDE_DIMENSIONS(DIM_PTR,D1)
ELSE IF CUR_OP=NULL THEN
DIM_PTR←D1
ELSE ERROR(1234, "Can't do this");
CUR_OP←NULL;
GET_TOKEN;
β;
β;
IF COUNT≠0 THEN F_STATE(0,65,"Parens don't match.");
if current≠ null_record then error(1112,"Incomplete evaluation");
D1←DIM_PTR;
IF D1=NULL OR D1=NIL_DIMENS THEN
insert_entry(DIMEN_NAME,DIMENSION_TYPE_TABLE)
ELSE INSERT_ENTRY(DIMEN_NAME,DIMENSION_TYPE_TABLE,D1);
REJECT←TRUE;
β "dimen_p";
! abort_P;
procedure abort_P;
α ! PRINT/ABORT/PAUSE STATEMENT FOUND;
IF EQU(TOKEN,"PAUSE") THEN
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠numeric_token then F_STATE(0,1102,
"Need a numeric value here for a PAUSE statement.");
PRINT("(PAUSE "&TOKEN&")");
β
ELSE
IF EQU(TOKEN,"NOTE") OR EQU(TOKEN,"NOTE1") OR EQU(TOKEN,"NOTE2") THEN
α
BOOLEAN LPAR; STRING T,T2;
LPAR←FALSE;
T←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"(") THEN α LPAR←TRUE; GET_TOKEN β;
IF TYPE_OF_TOKEN≠string_token then F_STATE(0,1102,
"Need string expression here for "& token & " statement.")
ELSE
α T2←TOKEN;
IF LPAR THEN α GET_TOKEN; IF ¬EQU(TOKEN,")") THEN ERROR(1234,
"Parenthesis mismatch.") β;
PRINT("( "& T & space & dquote & T2 & dquote & " )");
β;
β
ELSE α
PRINT("("&TOKEN&" ");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1104,"Need left paren here, continue will insert it.");
TOKEN←",";
WHILE EQU(TOKEN,",") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN=string_token THEN PRINT(dquote&TOKEN&dquote)
ELSE α
REJECT←TRUE;
P_EXP;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(1103,"Illegal separator. Continue"&
" will try to insert reasonable separator.");
β;
IF ¬EQU(TOKEN,")") THEN
ERROR(1104,"Need right paren here, continue will insert it.");
SPACING←SPACING-1;
PRINT(")");
β;
β;
! P_statement execution starts here;
LABL←CHANGER_HEAD; ! USUALLY NULL EXCEPT WHEN INSIDE A CHANGER.;
CHANGER_HEAD←null; LABEL_TYPE←0; GET_TOKEN;
DIM_PTR←NULL_RECORD;
WHILE EQU(TOKEN,"COMMENT") DO
α GARB←READ(semicolon_A_break); GET_TOKEN; β;
TRY_AGAIN:
IF TYPE_OF_TOKEN=numeric_token
THEN F_STATE(0,1,"Statement can't begin with a scalar")
ELSE IF TYPE_OF_TOKEN=string_token
THEN F_STATE(0,2,"Statement can't begin with a string")
ELSE IF TYPE_OF_TOKEN=id_token or type_of_res_word=metric_res
THEN
α RECORD_POINTER (ID_LIST) POINT;
RECORD_POINTER(DIMENS_EXPONENT)D1;
IF DIM_PTR=NULL_RECORD AND (D1←CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE))≠NULL_RECORD
THEN α DIM_PTR←D1;
GET_TOKEN; GOTO TRY_AGAIN;β
ELSE IF CHECK_ENTRY(TOKEN,DIMENSION_TYPE_TABLE)≠NULL_RECORD AND DIM_PTR≠NULL_RECORD
THEN F_STATE(0,55,"AMBIGUOUS DIMENSIONS")
ELSE
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD AND ID_LIST:TYPE[POINT]>world_VALUE THEN
α
LABEL_TYPE←ID_LIST:TYPE[POINT];
IF ID_LIST:LABEL_USED[POINT] THEN
ERROR(22,"Label multiply defined.");
ID_LIST:LABEL_USED[POINT]←TRUE;
IF EQU(LABL,null)
THEN LABL←TOKEN&" "
ELSE ERROR(22,"Double label.");
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN
ERROR_REJECT(23,"Colon needed here. Continue will insert it.");
IF LABEL_TYPE=cm_label_VALUE THEN
α
GET_TOKEN;
REJECT←TRUE;
IF ¬EQU(TOKEN,"ON") THEN ERROR(45,"Label mismatch.");
β;
GET_TOKEN;
GO TO TRY_AGAIN;
β
ELSE IF POINT≠NULL AND ID_LIST:TYPE[POINT]≤trans_VALUE THEN
α STRING id, AS;
INTEGER ID_TYPE;
RECORD_POINTER(DIMENS_EXPONENT) ID_DIMEN;
id←TOKEN;
ID_TYPE←ID_LIST:TYPE[POINT];
ID_DIMEN←ID_LIST:DIMEN[POINT];
GET_TOKEN;
IF EQU(TOKEN,"←") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS "; REJECT←TRUE; β
ELSE α AS←"PAS "; β;
PRINT("("&LABL&AS&id);
SPACING←SPACING+1;
P_EXP;
IF ID_TYPE≠EXP_TYPE THEN ERROR(121,"Type mismatch on assignment.");
CHECK_DIMENSIONS("assignment statement",ID_DIMEN,EXP_DIMENS);
SPACING←SPACING-1;
PRINT(")");
β
ELSE IF EQU(TOKEN,"<") THEN
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
GET_TOKEN;
TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN
ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN
F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
IF (POINT←CHECK_ENTRY(TOKEN,ID_TYPE_TABLE))≠NULL_RECORD AND ID_LIST:TYPE[POINT]=clc_label_VALUE THEN
α
CLC_LAB←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN
α
REJECT←TRUE;
TEMP←FALSE;
PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")");
β
ELSE TEMP←TRUE;
β
ELSE α
REJECT←TRUE;
CLC_LAB←T_GEN;
TEMP←TRUE;
PRINT("(CLCLAB "&CLC_LAB&")");
β;
IF TEMP THEN
α
PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT("))");
β;
β;
β
ELSE IF POINT=NULL THEN F_STATE (0,24,"Undefined ID.")
ELSE F_STATE(0,25,"Can't start statement this way.");
β
ELSE IF ¬(statement_beg ≤ TYPE_OF_RES_WORD ≤ statement_end) THEN
F_STATE(0,3,"Statement can't begin with <"&TOKEN&">")
ELSE CASE TYPE_OF_RES_WORD - statement_beg OF
α
redefine xx(str)=[redefine xx_temp="str" & "_P"; xx_temp;];
redefine yy(str)=[];
redefine zz(str)=[redefine zz_temp="str" & "_P"; zz_temp;];
statement_definitions;
β;
FLUSH:
β "P_STATEMENT";
! process_switches, got_input, got_output, open_logging_file;
procedure process_switches(record_pointer(file) F);
α record_pointer(file_switch) swt;
swt ← file:switches[F];
while swt≠null_record do
α integer i;
for i ← 0 step 1 until switch_max do
if equ(file_switch:name[swt], switch_name[i])
then α switch_setting[i] ← true; done β;
if i > switch_max then
outstr("""" & file_switch:name[swt] & """ unknown switch"& crlf);
swt ← file_switch:next[swt]
β
β;
boolean procedure got_input(record_pointer(file) F);
α
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
if eof ∧ length(file:ext[F])=0 ∧ length(file:def_ext[f])≠0 then
α "try default"
file:ext[F] ← file:def_ext[F];
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
β "try default";
process_switches(F);
return(¬eof)
β;
boolean procedure got_output(record_pointer(file) F);
α
string filename;
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
if length(file:ext[F])=0 then file:ext[F] ← file:def_ext[F];
filename ← make_file_name(F);
enter(file:chn[F], filename, file:eof[F]); process_switches(F);
return(¬eof)
β;
procedure open_logging_file;
if ¬log_file_open then
α;
LOG_file←new_record(file);
copy_file_record(LOG_file,BIN_file);
file:mode[LOG_file]←0; file:in_bfrs[LOG_file]← 0;
file:out_bfrs[LOG_file]←12; file:ext[LOG_file] ← "LOG";
file:device[LOG_file]← "DSK";
file:name[LOG_file]←file:name[AL_file];
if ¬got_output(LOG_file) then
usererr(0, 1, "can't get output");
CHANLOG ← file:chn[LOG_file];
LOGFILE←make_file_name(LOG_file);
log_file_open←true;
logging←true;
β;
! execution starts here, initialization;
procedure update_break_RS;
α
SETBREAK(word_R_break, TABLE1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1, NULL, "INSK");
β;
procedure add_to_table1(string s);
α TABLE1←TABLE1&S;
update_break_RS;
β;
procedure remove_from_table1(string s);
α
integer temp;
setbreak(temp←getbreak,null,s,"O");
TABLE1←SCAN(TABLE1,TEMP,BRCHAR);
update_break_RS;
RELBREAK(TEMP);
β;
α "execution"
COUNT ← 1000; DELIMITER_1 ← DELIMITER_2 ← 0; top_delimiters ← null_record;
OPEN_BRACE← "{" ;
TABLE1 ← "⊂⊃%,.;:[](){}+-*/#∧∨¬⊗&≤≥<>≠=←↑→?|" & lf & cr & dquote & tab & ff & space;
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRK");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRK");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSK");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRK");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISK");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAK");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANK");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANK");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANK");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRK");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
macro_delimiter_break ← getbreak;
TTYUP(TRUE);
! set up input and output;
if rpgsw then
α
cmd_line ← tmpin("AL", eof);
if eof
then α usererr(0, 1, "TMPIN lost"); rpgsw ← false β
else outstr(crlf & "AL: ");
β;
if ¬rpgsw then α outstr(crlf & "*"); cmd_line ← instrl(cr) β;
BIN_file ← new_record(file); ALL_file ← new_record(file);
SEX_file ← new_record(file); T←TRUE;
while true do
α "command" define want_BAIL=[switch_setting[b_X]];
want_BAIL ← false;
if ¬T then α outstr(crlf & "*"); cmd_line ← instrl(cr) β; T ← false;
AL_file ← scan_command(cmd_line, BIN_file, ALL_file);
if file:eof[AL_file] then
α usererr(0, 1, "null input spec"); continue "command" β;
! there was a special check for input named "DISPLAY" ;
file:mode[AL_file] ← 0; file:in_bfrs[AL_file] ← 12; file:out_bfrs[AL_file] ← 0;
file:def_ext[AL_file] ← "AL";
if ¬got_input(AL_file) then
α outstr(infile & "file not found"); continue "command" β;
copy_file_record(SEX_file, BIN_file);
file:mode[SEX_file] ← 0; file:in_bfrs[SEX_file] ← 0;
file:out_bfrs[SEX_file] ← 12; file:ext[SEX_file] ← "SEX";
if file:eof[SEX_file] then
α "null output spec"
file:device[SEX_file] ← "DSK";
file:name[SEX_file] ← file:name[AL_file]
β "null output spec";
if ¬got_output(SEX_file) then
α usererr(0, 1, "can't get output"); continue "command" β;
outfile←make_file_name(SEX_file);
chanin ← file:chn[AL_file]; chanout ← file:chn[SEX_file];
pagenum ← linenum ← sourcelvl ← 0; outstr(infile & " 1");
typed_page_num ← true;
ifc debug_compile thenc if want_BAIL then BAIL; endc
done "command"
β "command";
! set up predefined dimensions, constants and variables;
redefine zz(temp)=[];
redefine yy(temp,temp2)=[
redefine xx_temp= "DIMENS_EXPONENT:"&"temp"&"["&"temp"&"_DIMENS]←1;";
qq(temp)
xx_temp];
redefine qq(temp)=[redefine xxcount=xxcount+1;
redefine yytemp= "temp"&"_DIMENS←NEW_RECORD(DIMENS_EXPONENT);";
redefine zztemp= "DIMENS_EXPONENT:NAME["&"temp"&"_DIMENS]←"&""""&"temp"&""""&";";
redefine xxtemp(xxxcount)=
"D_TABLE["&"xxxcount" & "] ← INSERT_ENTRY("&""""&"temp"
&""""&",DIMENSION_TYPE_TABLE,"&"temp"&"_DIMENS);";
yytemp
zztemp
xxtemp(xxcount)];
redefine xxcount=-1;
metric_definitions;
FOR I←1 STEP 1 UNTIL const_count DO
α RECORD_POINTER (ID_LIST) TEMP; INTEGER INDEX;
TEMP←NEW_RECORD(ID_LIST);
INSERT_ENTRY(PRECONST[I],ID_TYPE_TABLE,TEMP);
ID_LIST:TYPE[TEMP]←PRECONST_TYPE[I];
ID_LIST:DIMEN[TEMP]←D_TABLE[PRE_DIMENS[I]];
β;
! PARSE PROGRAM;
spacing ← 0; print("(PR"); SPACING ← 1; BLOCK_LEVEL←0;
! **********; P_STATEMENT; ! **********;
IF TOP_SOURCE≠NULL_RECORD OR ¬EQU(INPUT(CHANIN,omit_break),null) THEN
ERROR(200,"Misc. garbage found after last end.");
spacing ← 0; print(")");
! CLEAN UP;
IF CHANIN≠-1 THEN RELEASE(CHANIN);
WHILE TOP_SOURCE≠NULL DO
α
IF SOURCE_LIST:CHAN[TOP_SOURCE]≠-1 THEN RELEASE(SOURCE_LIST:CHAN[TOP_SOURCE]);
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β;
CLOSO(CHANOUT);
CLOSO(CHANLOG);
β "execution";
α "swap" integer array swap[0:10]; string s; integer tmperr;
if length(file:ext[BIN_file])=0 then file:ext[BIN_file] ← "BIN";
s ← make_file_name(BIN_file) & "," & make_file_name(ALL_file) & "←" & outfile;
α "switches_for_ALC" boolean seen_one; integer i;
seen_one ← false;
for i ← 0 step 1 until switch_max do
if switch_setting[i] then
α
if ¬seen_one then α s ← s & "("; seen_one ← true β;
s ← s & switch_name[i];
β;
if seen_one then s ← s & ")";
β "switches_for_ALC";
tmpout("ALC", s, tmperr);
if tmperr then usererr(0, 1, "Trouble with TMPOUT");
outstr(crlf);
swap[0] ← cvsix("DSK"); swap[1] ← cvfil("ALC.DMP[HAL,HE]", swap[2], swap[4]);
swap[3] ← 1; ! start job in RPG mode; swap[5] ← 0;
call(location(swap[0]), "SWAP");
β "swap";
β "hidden_parse";
hidden_parse;
END "PARSE";